@@ -229,7 +249,10 @@ data |>
summarise(n = n()) |>
mutate(category2 = sprintf("%s (%s)", category2, n)) |>
ggplot(aes(fill = category2, values = n)) +
- geom_waffle(n_rows = 17, size = 0.2, colour = "#FFFFFC", flip = FALSE, na.rm = TRUE) +
+ geom_waffle(
+ n_rows = 17, size = 0.2, colour = "#FFFFFC",
+ flip = FALSE, na.rm = TRUE
+ ) +
scale_fill_daniel(palette = "staalmeesters", name = NULL) +
coord_equal() +
theme_bach(base_family = "Alegreya", base_size = 14) +
@@ -246,40 +269,48 @@ data |>
The dataset I just created was comprehensive and clean, but it didn't contain any information about the musical properties other than the setting. I want to dive into the setting later, but it's going to be a regular expression hell. I might come back to that later. In the meantime, Wikipedia has a page listing the compositions by Bach too (because of course Wikipedia does). This page contains approximate dates on each composition, as well as the key it was written in. I'm going to scrape this webpage too. The setup of this page was somewhat simpler, so scraping it was slightly simpler.
``` r
-url <- "https://en.wikipedia.org/wiki/List_of_compositions_by_Johann_Sebastian_Bach"
+website <- "https://en.wikipedia.org"
+article <- "wiki/List_of_compositions_by_Johann_Sebastian_Bach"
+url <- str_glue("{website}/{article}")
webpage <- read_html(url)
wikitext <- webpage |>
- html_nodes(xpath='//*[@id="TOP"]') |>
+ html_nodes(xpath = '//*[@id="TOP"]') |>
html_table(fill = TRUE) |>
- as.data.frame()
+ as.data.frame() |>
+ janitor::clean_names()
```
Then I cleaned the data somewhat and extracted the number from the BWV columns.
``` r
wikidata <- wikitext |>
- rename(BWV_full = BWV) |>
- mutate(BWV = sub('.*(\\d{3}).*', '\\1', BWV_full),
- BWV = parse_integer(BWV)) |>
- filter(!rev(duplicated(rev(BWV))))
+ rename(bwv_full = bwv) |>
+ mutate(
+ bwv = sub(".*(\\d{3}).*", "\\1", bwv_full),
+ bwv = parse_integer(bwv)
+ ) |>
+ filter(!rev(duplicated(rev(bwv))))
```
Then I merged the data. I lost a number of compositions in the process, but I was okay with it, mostly because it took me too much time and effort to try and fix it. Hurray for laziness. I extracted the year from the slightly messy `Date` column. Some strings in this column contain two dates, one for the first compilation and one for the date of completion. I extracted the last number, the year of completion.
``` r
-merged_data <- merge(data, wikidata, by = "BWV") |>
- mutate(year = sub(".*(\\d{4}).*", "\\1", Date),
- year = as.numeric(year),
- age = year - 1685)
+merged_data <- data |>
+ inner_join(wikidata, by = "bwv") |>
+ mutate(
+ year = sub(".*(\\d{4}).*", "\\1", date),
+ year = as.numeric(year),
+ age = year - 1685
+ )
```
I noticed that some entries in the `year` column exceeded the year of Bach's death. Bach died in 1750. I assumed that these years indicated the year of first performance or publication. In this scenario, it would be possible that certain pieces were lost and rediscovered at a later date and only then published. I thought to make a barplot of the number of compositions Bach over the course of his life, trying to see if there was any period where he was particularly productive. I also added some annotations to give the plot some context.
``` r
-BWVperyear <- merged_data |>
+bwvperyear <- merged_data |>
filter(!is.na(year)) |>
- group_by(year,age) |>
+ group_by(year, age) |>
summarise(n = n())
palette <- daniel_pal("staalmeesters")(6)
@@ -300,34 +331,66 @@ annotation2 <- data.frame(
text = "italic(Schemellis~Gesangbuch)~comes~out"
)
-ggplot(BWVperyear, aes(x = year, y = n, fill = n)) +
+ggplot(bwvperyear, aes(x = year, y = n, fill = n)) +
geom_bar(stat = "identity") +
- geom_vline(xintercept = c(1750.5,1685), linetype = "dashed", color = "grey30") +
- geom_text(data = data.frame(), mapping = aes(x = 1685.5, y = 75, label = "Bach was born\nMarch 31st 1685\nin Eisenach"),
- inherit.aes = FALSE, family = "Alegreya", hjust = 0) +
- geom_text(data = data.frame(), mapping = aes(x = 1750, y = 75, label = "Bach died\nJuly 28th 1750\nin Leipzich"),
- inherit.aes = FALSE, family = "Alegreya", hjust = 1) +
- geom_curve(data = annotation1, mapping = aes(x = x, y = y, xend = xend, yend = yend),
- arrow = arrow(angle = 25, length = unit(6,"pt")),
- curvature = 0.1, inherit.aes = FALSE) +
- geom_text(data = annotation1, mapping = aes(x = x, y = y + 4, label = text),
- family = "Alegreya", inherit.aes = FALSE, parse = FALSE) +
- geom_curve(data = annotation2, mapping = aes(x = x, y = y, xend = xend, yend = yend),
- arrow = arrow(angle = 25, length = unit(6,"pt")),
- curvature = 0.2, inherit.aes = FALSE) +
- geom_text(data = annotation2, mapping = aes(x = x, y = y + 3, label = text),
- family = "Alegreya", inherit.aes = FALSE, parse = TRUE) +
- labs(x = "Year",
- y = "Number of compositions") +
- scale_x_continuous(limits = c(1685,1751), breaks = seq(1690,1750,10)) +
+ geom_vline(
+ xintercept = c(1750.5, 1685),
+ linetype = "dashed", color = "grey30"
+ ) +
+ geom_text(
+ data = data.frame(),
+ mapping = aes(
+ x = 1685.5, y = 75,
+ label = "Bach was born\nMarch 31st 1685\nin Eisenach"
+ ),
+ inherit.aes = FALSE, family = "Alegreya", hjust = 0
+ ) +
+ geom_text(
+ data = data.frame(),
+ mapping = aes(
+ x = 1750, y = 75,
+ label = "Bach died\nJuly 28th 1750\nin Leipzich"
+ ),
+ inherit.aes = FALSE, family = "Alegreya", hjust = 1
+ ) +
+ geom_curve(
+ data = annotation1,
+ mapping = aes(x = x, y = y, xend = xend, yend = yend),
+ arrow = arrow(angle = 25, length = unit(6, "pt")),
+ curvature = 0.1, inherit.aes = FALSE
+ ) +
+ geom_text(
+ data = annotation1,
+ mapping = aes(x = x, y = y + 4, label = text),
+ family = "Alegreya", inherit.aes = FALSE, parse = FALSE
+ ) +
+ geom_curve(
+ data = annotation2,
+ mapping = aes(x = x, y = y, xend = xend, yend = yend),
+ arrow = arrow(angle = 25, length = unit(6, "pt")),
+ curvature = 0.2, inherit.aes = FALSE
+ ) +
+ geom_text(
+ data = annotation2,
+ mapping = aes(x = x, y = y + 3, label = text),
+ family = "Alegreya", inherit.aes = FALSE, parse = TRUE
+ ) +
+ labs(
+ x = "Year",
+ y = "Number of compositions"
+ ) +
+ scale_x_continuous(
+ limits = c(1685, 1751),
+ breaks = seq(1690, 1750, 10)
+ ) +
scale_fill_gradient(low = palette[6], high = palette[2]) +
theme_bach(base_family = "Alegreya", grid = "y") +
theme(
- legend.position = 'none'
- )
+ legend.position = "none"
+ )
```
-
+
It seems there were two particularly productive years. But since the year column likely indicates year of publication, it's perhaps more likely that Bach published a collection of pieces in a batch. This is certainly true for the year 1736, when the *Schemellis Gesangbuch* came out, a song book with sacred music, written together with a student of the school he was cantor at: the *Thomasschule* in Leipzich. I'll come back to this plot later.
@@ -335,28 +398,24 @@ The Wikipedia page also contained information on the key of most of the composit
``` r
summ_key_cat1 <- merged_data |>
- group_by(category1, Key) |>
+ group_by(category1, key) |>
summarise(n = n()) |>
- filter(nchar(Key) > 1) |>
- mutate(Key = sub("\u266D", "b", Key),
- Key = sub("\U266F", "#", Key),
- Key = ifelse(nchar(Key) > 10, substring(Key,1,nchar(Key)/2), Key)
+ filter(nchar(key) > 1) |>
+ mutate(
+ Key = sub("\u266D", "b", key),
+ Key = sub("\U266F", "#", key),
+ Key = ifelse(nchar(key) > 10, substring(key, 1, nchar(key) / 2), key)
) |>
- group_by(category1, Key) |>
+ group_by(category1, key) |>
summarise(n = sum(n))
-```
-
- `summarise()` has grouped output by 'category1'. You can override using the
- `.groups` argument.
- `summarise()` has grouped output by 'category1'. You can override using the
- `.groups` argument.
-``` r
-ggplot(summ_key_cat1, aes(x = reorder(Key,-n), y = n, fill = category1)) +
+ggplot(summ_key_cat1, aes(x = reorder(key, -n), y = n, fill = category1)) +
geom_col(position = position_dodge2(preserve = "single", padding = 0)) +
- labs(x = NULL,
- y = "Number of compositions",
- fill = NULL) +
+ labs(
+ x = NULL,
+ y = "Number of compositions",
+ fill = NULL
+ ) +
scale_fill_daniel(palette = "staalmeesters") +
theme_bach(base_family = "Alegreya", grid = "y") +
theme(
@@ -371,31 +430,42 @@ I noticed that there were no double keys, as in B flat is the same as A sharp. T
``` r
summ_key_cat2 <- merged_data |>
- group_by(category2, Key) |>
+ group_by(category2, key) |>
summarise(n = n()) |>
- filter(nchar(Key) > 1) |>
- mutate(Key = sub("\u266D", "b", Key),
- Key = sub("\U266F", "#", Key),
- Key = ifelse(nchar(Key) > 10, substring(Key,1,nchar(Key)/2), Key)
+ filter(nchar(key) > 1) |>
+ mutate(
+ key = sub("\u266D", "b", key),
+ key = sub("\U266F", "#", key),
+ key = ifelse(nchar(key) > 10, substring(key, 1, nchar(key) / 2), key)
) |>
- group_by(category2, Key) |>
+ group_by(category2, key) |>
summarise(n = sum(n))
-plotdat <- rbind(summ_key_cat1 |> rename(category2 = category1),
- summ_key_cat2) |>
- cbind(gr = c(rep(1,nrow(summ_key_cat1)),
- rep(2,nrow(summ_key_cat2)))
- )
+plotdat <- rbind(
+ summ_key_cat1 |> rename(category2 = category1),
+ summ_key_cat2
+) |>
+ cbind(gr = c(
+ rep(1, nrow(summ_key_cat1)),
+ rep(2, nrow(summ_key_cat2))
+ ))
-ggplot(plotdat, aes(x = Key, y = reorder(category2,n), fill = n)) +
+ggplot(plotdat, aes(x = key, y = reorder(category2, n), fill = n)) +
geom_tile() +
geom_text(aes(label = n), family = "Alegreya", color = "white", size = 4) +
- geom_hline(yintercept = 8.5, color = "#FFFFF0", size = 1) +
- labs(x = NULL,
- y = NULL,
- fill = NULL) +
+ geom_hline(yintercept = 8.5, color = "#FFFFF0", size = 1) +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = NULL
+ ) +
scale_x_discrete(position = "top") +
- scale_fill_gradient(low = palette[6], high = palette[2], breaks = c(1,seq(10,40,10)),guide = guide_colorbar(barheight = 8, barwidth = 0.75)) +
+ scale_fill_gradient(
+ low = palette[6],
+ high = palette[2],
+ breaks = c(1, seq(10, 40, 10)),
+ guide = guide_colorbar(barheight = 8, barwidth = 0.75)
+ ) +
coord_fixed() +
theme_bach(base_family = "Alegreya", grid = FALSE) +
theme(
@@ -415,9 +485,12 @@ In addition to this, I also wanted to do some classic journalism. Previously, I
``` r
register_google(google_code)
places <- data_frame(
- city = c("Eisenach","Ohrdruf","Lüneburg","Weimar","Arnstadt","Mühlhausen","Weimar","Köthen","Leipzig"),
- year_from = c(1685,1695,1700,1702,1703,1707,1708,1717,1723),
- year_to = c(1695,1700,1702,1703,1707,1708,1717,1723,1750)
+ city = c(
+ "Eisenach", "Ohrdruf", "Lüneburg", "Weimar",
+ "Arnstadt", "Mühlhausen", "Weimar", "Köthen", "Leipzig"
+ ),
+ year_from = c(1685, 1695, 1700, 1702, 1703, 1707, 1708, 1717, 1723),
+ year_to = c(1695, 1700, 1702, 1703, 1707, 1708, 1717, 1723, 1750)
) |>
mutate_geocode(city) |>
mutate(duration = year_to - year_from)
@@ -439,12 +512,14 @@ Lastly, just for fun, I created a map.
places_unique <- places |>
distinct(city, .keep_all = TRUE)
-ggplot(places_unique, aes(x = lon, y = lat)) +
+ggplot(places_unique, aes(x = lon, y = lat)) +
borders("world", colour = palette[3], fill = palette[4], alpha = 1) +
geom_point(color = palette[1], size = 4) +
- ggrepel::geom_text_repel(aes(label = city), force = 1, size = 4,
- seed = 2345, point.padding = 0.2,
- family = "Alegreya") +
+ ggrepel::geom_text_repel(aes(label = city),
+ force = 1, size = 4,
+ seed = 2345, point.padding = 0.2,
+ family = "Alegreya"
+ ) +
coord_quickmap(xlim = c(4, 18), ylim = c(48, 55)) +
theme_void()
```
diff --git a/content/blog/2019-analyzing-bach/index.qmd b/content/blog/2019-analyzing-bach/index.qmd
index 57fb017..dfe3835 100644
--- a/content/blog/2019-analyzing-bach/index.qmd
+++ b/content/blog/2019-analyzing-bach/index.qmd
@@ -14,6 +14,8 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
```{css}
@@ -34,12 +36,10 @@ h2, h3, h4, h5, h6 {
}
```
-
## Introduction
A little while ago I was watching a documentary series on Dutch television about one of the most important composers in the Netherlands: Johann Sebastian Bach. The documentary discussed parts of Bach's life and the music he wrote during it. This documentary inspired me to learn more about the pieces Bach wrote, and since this is my life now, I might as well do it in R.
-
## Collecting the data
In my search of a dataset, I found this old website, looking like it last got a major update in 2003, made by what appeared to be a Bach enthousiast called Bryen Travis. I tried to contact him to see if he was interested in collaborating, but I couldn't get a hold of him. This website contained a list of all works by Bach, with some information about each of them. The website listed a few options, an online browser, a pdf containing slimmed down entries, and two files that I couldn't get to work, presumably because they were in a format that have presumably become depracated since they were uploaded back in 1996, when the website was created. I could have used the pdf, but since it contained only the BWV number, the title of the piece, and the setting, I had to scrape the data I wanted from the website directly.
@@ -66,9 +66,6 @@ library(danielR)
#| echo: false
theme_bach <- theme_daniel
-
-#palette <- c('#555555','#db735c', '#EFA86E', '#9A8A76', '#F3C57B',
-# '#7A6752', '#2A91A2', '#87F28A', '#6EDCEF')
```
Let's collect the BWVs:
@@ -77,7 +74,7 @@ Let's collect the BWVs:
#| label: scrape-index
index_url <- "http://www.bachcentral.com/BWV/index.html"
-BWVs <- paste(readLines(index_url), collapse = "\n") |>
+bwvs <- paste(readLines(index_url), collapse = "\n") |>
str_match_all("
unlist() |>
unique() |>
@@ -86,7 +83,7 @@ BWVs <- paste(readLines(index_url), collapse = "\n") |>
unique() |>
str_extract_all("[0-9]+") |>
as.character()
-str(BWVs)
+str(bwvs)
```
I now have a list of 1075 numbers, corresponding to BWV numbers of which this website has an entry. The next thing I needed to do now was loop over these numbers, navigate to each of the webpages corresponding to that link, and scrape all 1075 webpages individually. This takes a little bit of time, but luckily the author of the pages was very consistent in the setup, so I didn't need to build in fail-safes or condititions to account for irregularities. Before we'll do that, I first initialized a data frame with the correct size for speed. I added the column names for convenience too.
@@ -94,42 +91,55 @@ I now have a list of 1075 numbers, corresponding to BWV numbers of which this we
```{r}
#| label: collect-scrape-index
-col_names <- c("Title", "Subtitle_and_notes",
- "BWV", "BWV_epifix", "CLC_BWV_w_epifix", "belongs after",
- "voices_instruments",
- "category1", "category2", "category3",
- "cantate_cat1", "cantate_cat2")
+col_names <- c(
+ "Title", "Subtitle_and_notes",
+ "BWV", "BWV_epifix", "CLC_BWV_w_epifix", "belongs after",
+ "voices_instruments",
+ "category1", "category2", "category3",
+ "cantate_cat1", "cantate_cat2"
+)
-scraped_data <- data.frame(matrix(ncol = 12, nrow = length(BWVs)))
+scraped_data <- data.frame(matrix(ncol = 12, nrow = length(bwvs)))
colnames(scraped_data) <- col_names
```
## Scraping the data
+
We now have a variable of the same dimensions and column names as I'll scrape from the website. Now it's time to loop through the webpages and collect the data. Each webpage contains what looks like a table, but within the table it's bulleted lists (denoted as `ul`). This might just be how html builds up tables, but I thought it was a bit strange. Nonetheless, it provided me with an easy hook to grab the values. I remove all the white spaces (`\t`), and each new line was denoted by a `\n`, which I used to split the strings into separate values. The advantage of this approach is that when a field is empty, it will still occupy an element in the character array. Then all I needed to do to obtain the values is take every second element and add it as a row to the data frame I created earlier. Now I have a dataset containing the values from all of the 1075 webpages, with which I was quite pleased.
```{r}
#| label: scrape-data
#| eval: false
-for (i in 1:length(BWVs)) {
-
- print(sprintf("Scraping data for BWV %s", BWVs[i]))
-
- url <- sprintf("http://www.bachcentral.com/BWV/%s.html", BWVs[i])
+for (i in seq_along(length(bwvs))) {
+ print(sprintf("Scraping data for BWV %s", bwvs[i]))
+
+ url <- sprintf("http://www.bachcentral.com/BWV/%s.html", bwvs[i])
webpage <- read_html(url)
-
+
text <- webpage |>
html_nodes("ul") |>
html_text() |>
- gsub('[\t]', '', .) |>
+ gsub("[\t]", "", .) |>
strsplit(., "\\n") |>
unlist()
-
- values <- text[seq(2,length(text),2)]
-
+
+ values <- text[seq(2, length(text), 2)]
+
scraped_data[i, ] <- values
-
}
+
+scraped_data <- scraped_data |>
+ janitor::clean_names()
+```
+
+```{r}
+#| label: save-scraped
+#| eval: false
+#| echo: false
+
+scraped_data |>
+ write_rds("./data/scraped_data.rds")
```
With this, I achieved the first goal I had for this little project, which was to find or create a dataset on Bach. Let's see what it looks like:
@@ -138,13 +148,14 @@ With this, I achieved the first goal I had for this little project, which was to
#| label: load-scraped
#| echo: false
-load("scraped_data.Rdata")
+scraped_data <- read_rds("./data/scraped_data.rds") |>
+ janitor::clean_names()
```
```{r}
#| label: str-scraped
-str(scraped_data)
+glimpse(scraped_data)
```
All columns are currently character arrays, and this is appropriate for most of them. Although I think the BWV number alone could be a numeric array. Also, some columns are still a bit awkward. This is why I moved on to do another important and satisfying part, cleaning the data.
@@ -157,15 +168,17 @@ The character arrays are appropriate, but for further analyes I'd prefer to make
#| label: clean-scraped
data <- scraped_data |>
- mutate(BWV = as.numeric(BWV),
- category1 = factor(category1),
- category2 = factor(category2),
- category3 = factor(category3),
- cantate_cat1 = substring(cantate_cat1,4),
- CLC_BWV_w_epifix = str_replace(CLC_BWV_w_epifix, " ", "")) |>
- rename(BWV_w_epifix = CLC_BWV_w_epifix) |>
- select(BWV, BWV_epifix, BWV_w_epifix, everything())
-str(data)
+ mutate(
+ bwv = as.numeric(bwv),
+ category1 = factor(category1),
+ category2 = factor(category2),
+ category3 = factor(category3),
+ cantate_cat1 = substring(cantate_cat1, 4),
+ clc_bwv_w_epifix = str_squish(clc_bwv_w_epifix)
+ ) |>
+ rename(bwv_w_epifix = clc_bwv_w_epifix) |>
+ select(bwv, bwv_epifix, bwv_w_epifix, everything()) |>
+ glimpse()
```
Now we have this data, we can do some descriptive visualizations of the data. Over time I hope I can dive into the setting (`voices_instruments`) and disect that, but for now I'll keep it simple and just do some descriptives.
@@ -181,19 +194,27 @@ data |>
group_by(category1) |>
summarise(n = n()) |>
ggplot(aes(x = category1, y = n, color = category1)) +
- geom_segment(aes(xend = category1, yend = 0), size = 12,
- color = "grey40", alpha = 0.9) +
- geom_point(size = 20, shape = 16) +
- geom_text(aes(label = n, y = n + 5), color = "white", size = 5, family = "Alegreya") +
- labs(x = NULL,
- y = "Number of compositions") +
+ geom_segment(aes(xend = category1, yend = 0),
+ linewidth = 12,
+ color = "grey40", alpha = 0.9
+ ) +
+ geom_point(size = 20, shape = 16) +
+ geom_text(aes(label = n, y = n + 5),
+ color = "white", size = 5, family = "Alegreya"
+ ) +
+ geom_hline(yintercept = 0, size = 1) +
+ labs(
+ x = NULL,
+ y = "Number of compositions"
+ ) +
scale_color_daniel(palette = "staalmeesters") +
- scale_y_continuous(limits = c(0,650)) +
+ scale_y_continuous(limits = c(0, 650)) +
theme_bach(base_family = "Alegreya", grid = "y") +
theme(
legend.position = "none",
- aspect.ratio = 3/2,
- axis.text.x = element_text(angle = 45, hjust = 1.1, vjust = 1.15))
+ aspect.ratio = 3 / 2,
+ axis.text.x = element_text(angle = 45, hjust = 1.1, vjust = 1.15)
+ )
```
It seems Bach didn't have a strong preference for either instrumental or choral music. I suppose he didn't have infinite freedom with what to compose, since his employer might also request him to compose certain types of music. I wanted to see the same for the secondary category, which differentias between the type of composition (e.g. cantate, passions, organ pieces, symphonies, and so on).
@@ -204,20 +225,26 @@ It seems Bach didn't have a strong preference for either instrumental or choral
data |>
group_by(category2) |>
summarise(n = n()) |>
- ggplot(aes(x = reorder(category2,-n), y = n, color = category2)) +
- geom_segment(aes(xend = category2, yend = 0), size = 6,
- color = "grey40", alpha = 0.9) +
- geom_point(size = 10, shape = 16) +
- geom_text(aes(label = n, y = n + 3), color = "white", size = 4, family = "Alegreya") +
- labs(x = NULL,
- y = "Number of compositions") +
+ ggplot(aes(x = reorder(category2, -n), y = n, color = category2)) +
+ geom_segment(aes(xend = category2, yend = 0),
+ size = 6,
+ color = "grey40", alpha = 0.9
+ ) +
+ geom_point(size = 10, shape = 16) +
+ geom_text(aes(label = n, y = n + 3),
+ color = "white", size = 4, family = "Alegreya"
+ ) +
+ labs(
+ x = NULL,
+ y = "Number of compositions"
+ ) +
scale_color_daniel(palette = "staalmeesters") +
- scale_y_continuous(limits = c(-5,300)) +
+ scale_y_continuous(limits = c(-5, 300)) +
theme_bach(base_family = "Alegreya", grid = "y") +
theme(
legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1.05, vjust = 1.025)
- )
+ )
```
From this it seems that most of the intrumental pieces are made up by just solo pieces for organ and the harpsichord and that the choral pieces are made up mostly by cantates and chorales for four voices. While I appreciate the information dissemination qualities of a barplot (or lollipop plot) like this, in that it's good in communicating absolute quantities (while I admit that this could also be displayed in a table). One thing it is less good at, is communicating the subjective volume of the works. There's more than a thousand pieces in the BWV, and I feel that the plots above don't do a good enough job at communicating just how many pieces this is. Therefore, I created a tile plot (using `{waffle}`), where every tile represents one piece. I colored again based on the secondary category. In order to still maintain the quantities of each category, I added the number of compositions to the legend.
@@ -231,7 +258,10 @@ data |>
summarise(n = n()) |>
mutate(category2 = sprintf("%s (%s)", category2, n)) |>
ggplot(aes(fill = category2, values = n)) +
- geom_waffle(n_rows = 17, size = 0.2, colour = "#FFFFFC", flip = FALSE, na.rm = TRUE) +
+ geom_waffle(
+ n_rows = 17, size = 0.2, colour = "#FFFFFC",
+ flip = FALSE, na.rm = TRUE
+ ) +
scale_fill_daniel(palette = "staalmeesters", name = NULL) +
coord_equal() +
theme_bach(base_family = "Alegreya", base_size = 14) +
@@ -246,11 +276,10 @@ data |>
#| echo: false
#| eval: false
-library(tidytext)
-title_words <- data |>
- select(Title) |>
- unnest_tokens(output = word, input = Title) |>
- anti_join(get_stopwords(language = "de")) |>
+title_words <- data |>
+ select(title) |>
+ tidytext::unnest_tokens(output = word, input = title) |>
+ anti_join(tidytext::get_stopwords(language = "de")) |>
count(word, sort = TRUE) |>
mutate(nchar = nchar(word)) |>
filter(nchar >= 3)
@@ -263,13 +292,16 @@ The dataset I just created was comprehensive and clean, but it didn't contain an
```{r}
#| label: scrape-wiki
-url <- "https://en.wikipedia.org/wiki/List_of_compositions_by_Johann_Sebastian_Bach"
+website <- "https://en.wikipedia.org"
+article <- "wiki/List_of_compositions_by_Johann_Sebastian_Bach"
+url <- str_glue("{website}/{article}")
webpage <- read_html(url)
wikitext <- webpage |>
- html_nodes(xpath='//*[@id="TOP"]') |>
+ html_nodes(xpath = '//*[@id="TOP"]') |>
html_table(fill = TRUE) |>
- as.data.frame()
+ as.data.frame() |>
+ janitor::clean_names()
```
Then I cleaned the data somewhat and extracted the number from the BWV columns.
@@ -279,10 +311,12 @@ Then I cleaned the data somewhat and extracted the number from the BWV columns.
#| warning: false
wikidata <- wikitext |>
- rename(BWV_full = BWV) |>
- mutate(BWV = sub('.*(\\d{3}).*', '\\1', BWV_full),
- BWV = parse_integer(BWV)) |>
- filter(!rev(duplicated(rev(BWV))))
+ rename(bwv_full = bwv) |>
+ mutate(
+ bwv = sub(".*(\\d{3}).*", "\\1", bwv_full),
+ bwv = parse_integer(bwv)
+ ) |>
+ filter(!rev(duplicated(rev(bwv))))
```
Then I merged the data. I lost a number of compositions in the process, but I was okay with it, mostly because it took me too much time and effort to try and fix it. Hurray for laziness. I extracted the year from the slightly messy `Date` column. Some strings in this column contain two dates, one for the first compilation and one for the date of completion. I extracted the last number, the year of completion.
@@ -291,23 +325,26 @@ Then I merged the data. I lost a number of compositions in the process, but I wa
#| label: merge-scraped
#| warning: false
-merged_data <- merge(data, wikidata, by = "BWV") |>
- mutate(year = sub(".*(\\d{4}).*", "\\1", Date),
- year = as.numeric(year),
- age = year - 1685)
+merged_data <- data |>
+ inner_join(wikidata, by = "bwv") |>
+ mutate(
+ year = sub(".*(\\d{4}).*", "\\1", date),
+ year = as.numeric(year),
+ age = year - 1685
+ )
```
I noticed that some entries in the `year` column exceeded the year of Bach's death. Bach died in 1750. I assumed that these years indicated the year of first performance or publication. In this scenario, it would be possible that certain pieces were lost and rediscovered at a later date and only then published. I thought to make a barplot of the number of compositions Bach over the course of his life, trying to see if there was any period where he was particularly productive. I also added some annotations to give the plot some context.
```{r}
-#| label: BWVperyear-plot
+#| label: bwvperyear-plot
#| warning: false
#| message: false
#| fig-width: 12
-BWVperyear <- merged_data |>
+bwvperyear <- merged_data |>
filter(!is.na(year)) |>
- group_by(year,age) |>
+ group_by(year, age) |>
summarise(n = n())
palette <- daniel_pal("staalmeesters")(6)
@@ -328,31 +365,63 @@ annotation2 <- data.frame(
text = "italic(Schemellis~Gesangbuch)~comes~out"
)
-ggplot(BWVperyear, aes(x = year, y = n, fill = n)) +
+ggplot(bwvperyear, aes(x = year, y = n, fill = n)) +
geom_bar(stat = "identity") +
- geom_vline(xintercept = c(1750.5,1685), linetype = "dashed", color = "grey30") +
- geom_text(data = data.frame(), mapping = aes(x = 1685.5, y = 75, label = "Bach was born\nMarch 31st 1685\nin Eisenach"),
- inherit.aes = FALSE, family = "Alegreya", hjust = 0) +
- geom_text(data = data.frame(), mapping = aes(x = 1750, y = 75, label = "Bach died\nJuly 28th 1750\nin Leipzich"),
- inherit.aes = FALSE, family = "Alegreya", hjust = 1) +
- geom_curve(data = annotation1, mapping = aes(x = x, y = y, xend = xend, yend = yend),
- arrow = arrow(angle = 25, length = unit(6,"pt")),
- curvature = 0.1, inherit.aes = FALSE) +
- geom_text(data = annotation1, mapping = aes(x = x, y = y + 4, label = text),
- family = "Alegreya", inherit.aes = FALSE, parse = FALSE) +
- geom_curve(data = annotation2, mapping = aes(x = x, y = y, xend = xend, yend = yend),
- arrow = arrow(angle = 25, length = unit(6,"pt")),
- curvature = 0.2, inherit.aes = FALSE) +
- geom_text(data = annotation2, mapping = aes(x = x, y = y + 3, label = text),
- family = "Alegreya", inherit.aes = FALSE, parse = TRUE) +
- labs(x = "Year",
- y = "Number of compositions") +
- scale_x_continuous(limits = c(1685,1751), breaks = seq(1690,1750,10)) +
+ geom_vline(
+ xintercept = c(1750.5, 1685),
+ linetype = "dashed", color = "grey30"
+ ) +
+ geom_text(
+ data = data.frame(),
+ mapping = aes(
+ x = 1685.5, y = 75,
+ label = "Bach was born\nMarch 31st 1685\nin Eisenach"
+ ),
+ inherit.aes = FALSE, family = "Alegreya", hjust = 0
+ ) +
+ geom_text(
+ data = data.frame(),
+ mapping = aes(
+ x = 1750, y = 75,
+ label = "Bach died\nJuly 28th 1750\nin Leipzich"
+ ),
+ inherit.aes = FALSE, family = "Alegreya", hjust = 1
+ ) +
+ geom_curve(
+ data = annotation1,
+ mapping = aes(x = x, y = y, xend = xend, yend = yend),
+ arrow = arrow(angle = 25, length = unit(6, "pt")),
+ curvature = 0.1, inherit.aes = FALSE
+ ) +
+ geom_text(
+ data = annotation1,
+ mapping = aes(x = x, y = y + 4, label = text),
+ family = "Alegreya", inherit.aes = FALSE, parse = FALSE
+ ) +
+ geom_curve(
+ data = annotation2,
+ mapping = aes(x = x, y = y, xend = xend, yend = yend),
+ arrow = arrow(angle = 25, length = unit(6, "pt")),
+ curvature = 0.2, inherit.aes = FALSE
+ ) +
+ geom_text(
+ data = annotation2,
+ mapping = aes(x = x, y = y + 3, label = text),
+ family = "Alegreya", inherit.aes = FALSE, parse = TRUE
+ ) +
+ labs(
+ x = "Year",
+ y = "Number of compositions"
+ ) +
+ scale_x_continuous(
+ limits = c(1685, 1751),
+ breaks = seq(1690, 1750, 10)
+ ) +
scale_fill_gradient(low = palette[6], high = palette[2]) +
theme_bach(base_family = "Alegreya", grid = "y") +
theme(
- legend.position = 'none'
- )
+ legend.position = "none"
+ )
```
It seems there were two particularly productive years. But since the year column likely indicates year of publication, it's perhaps more likely that Bach published a collection of pieces in a batch. This is certainly true for the year 1736, when the _Schemellis Gesangbuch_ came out, a song book with sacred music, written together with a student of the school he was cantor at: the _Thomasschule_ in Leipzich. I'll come back to this plot later.
@@ -361,23 +430,27 @@ The Wikipedia page also contained information on the key of most of the composit
```{r}
#| label: colplot-key-cat1
+#| message: false
summ_key_cat1 <- merged_data |>
- group_by(category1, Key) |>
+ group_by(category1, key) |>
summarise(n = n()) |>
- filter(nchar(Key) > 1) |>
- mutate(Key = sub("\u266D", "b", Key),
- Key = sub("\U266F", "#", Key),
- Key = ifelse(nchar(Key) > 10, substring(Key,1,nchar(Key)/2), Key)
+ filter(nchar(key) > 1) |>
+ mutate(
+ Key = sub("\u266D", "b", key),
+ Key = sub("\U266F", "#", key),
+ Key = ifelse(nchar(key) > 10, substring(key, 1, nchar(key) / 2), key)
) |>
- group_by(category1, Key) |>
+ group_by(category1, key) |>
summarise(n = sum(n))
-ggplot(summ_key_cat1, aes(x = reorder(Key,-n), y = n, fill = category1)) +
+ggplot(summ_key_cat1, aes(x = reorder(key, -n), y = n, fill = category1)) +
geom_col(position = position_dodge2(preserve = "single", padding = 0)) +
- labs(x = NULL,
- y = "Number of compositions",
- fill = NULL) +
+ labs(
+ x = NULL,
+ y = "Number of compositions",
+ fill = NULL
+ ) +
scale_fill_daniel(palette = "staalmeesters") +
theme_bach(base_family = "Alegreya", grid = "y") +
theme(
@@ -394,31 +467,42 @@ I noticed that there were no double keys, as in B flat is the same as A sharp. T
#| fig-width: 12
summ_key_cat2 <- merged_data |>
- group_by(category2, Key) |>
+ group_by(category2, key) |>
summarise(n = n()) |>
- filter(nchar(Key) > 1) |>
- mutate(Key = sub("\u266D", "b", Key),
- Key = sub("\U266F", "#", Key),
- Key = ifelse(nchar(Key) > 10, substring(Key,1,nchar(Key)/2), Key)
+ filter(nchar(key) > 1) |>
+ mutate(
+ key = sub("\u266D", "b", key),
+ key = sub("\U266F", "#", key),
+ key = ifelse(nchar(key) > 10, substring(key, 1, nchar(key) / 2), key)
) |>
- group_by(category2, Key) |>
+ group_by(category2, key) |>
summarise(n = sum(n))
-plotdat <- rbind(summ_key_cat1 |> rename(category2 = category1),
- summ_key_cat2) |>
- cbind(gr = c(rep(1,nrow(summ_key_cat1)),
- rep(2,nrow(summ_key_cat2)))
- )
+plotdat <- rbind(
+ summ_key_cat1 |> rename(category2 = category1),
+ summ_key_cat2
+) |>
+ cbind(gr = c(
+ rep(1, nrow(summ_key_cat1)),
+ rep(2, nrow(summ_key_cat2))
+ ))
-ggplot(plotdat, aes(x = Key, y = reorder(category2,n), fill = n)) +
+ggplot(plotdat, aes(x = key, y = reorder(category2, n), fill = n)) +
geom_tile() +
geom_text(aes(label = n), family = "Alegreya", color = "white", size = 4) +
- geom_hline(yintercept = 8.5, color = "#FFFFF0", size = 1) +
- labs(x = NULL,
- y = NULL,
- fill = NULL) +
+ geom_hline(yintercept = 8.5, color = "#FFFFF0", size = 1) +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = NULL
+ ) +
scale_x_discrete(position = "top") +
- scale_fill_gradient(low = palette[6], high = palette[2], breaks = c(1,seq(10,40,10)),guide = guide_colorbar(barheight = 8, barwidth = 0.75)) +
+ scale_fill_gradient(
+ low = palette[6],
+ high = palette[2],
+ breaks = c(1, seq(10, 40, 10)),
+ guide = guide_colorbar(barheight = 8, barwidth = 0.75)
+ ) +
coord_fixed() +
theme_bach(base_family = "Alegreya", grid = FALSE) +
theme(
@@ -439,9 +523,12 @@ In addition to this, I also wanted to do some classic journalism. Previously, I
register_google(google_code)
places <- data_frame(
- city = c("Eisenach","Ohrdruf","Lüneburg","Weimar","Arnstadt","Mühlhausen","Weimar","Köthen","Leipzig"),
- year_from = c(1685,1695,1700,1702,1703,1707,1708,1717,1723),
- year_to = c(1695,1700,1702,1703,1707,1708,1717,1723,1750)
+ city = c(
+ "Eisenach", "Ohrdruf", "Lüneburg", "Weimar",
+ "Arnstadt", "Mühlhausen", "Weimar", "Köthen", "Leipzig"
+ ),
+ year_from = c(1685, 1695, 1700, 1702, 1703, 1707, 1708, 1717, 1723),
+ year_to = c(1695, 1700, 1702, 1703, 1707, 1708, 1717, 1723, 1750)
) |>
mutate_geocode(city) |>
mutate(duration = year_to - year_from)
@@ -452,14 +539,14 @@ places <- data_frame(
#| echo: false
#| eval: false
-save(places, file = "places.Rdata")
+places |> write_rds("./data/places.rds")
```
```{r}
#| label: load-places
#| echo: false
-load("places.Rdata")
+places <- read_rds("./data/places.rds")
```
Since this time I wanted to visualize whether Bach was more productive in certain places, I recreated the plot from earlier, shaded the background with the city Bach inhabited at the time, and transformed the bars into a density plot, which smoothed over the data and removed the high outliers.
@@ -470,21 +557,42 @@ Since this time I wanted to visualize whether Bach was more productive in certai
#| fig-width: 12
places_plot <- places |>
- mutate(meanyear = year_from + ((year_to - year_from)/2))
+ mutate(meanyear = year_from + ((year_to - year_from) / 2))
ggplot(places_plot) +
- geom_rect(aes(xmin = year_from + 0.5, xmax = year_to + 0.5, ymin = 0, ymax = 60, fill = reorder(city,year_from)),
- alpha = 0.75) +
- stat_smooth(data = BWVperyear |> filter(year < 1751), mapping = aes(x = year + 0.5, y = n, group = 1), fill = "black", geom = 'area', method = 'loess', span = 0.225, alpha = 0.75) +
- geom_text(aes(x = meanyear, label = city, y = 62.5),
- family = "Alegreya", angle = 60, hjust = 0) +
- labs(x = NULL,
- y = "Number of compositions",
- fill = "City") +
+ geom_rect(
+ aes(
+ xmin = year_from + 0.5, xmax = year_to + 0.5,
+ ymin = 0, ymax = 60,
+ fill = reorder(city, year_from)
+ ),
+ alpha = 0.75
+ ) +
+ stat_smooth(
+ data = bwvperyear |> filter(year < 1751),
+ mapping = aes(x = year + 0.5, y = n, group = 1),
+ fill = "black", geom = "area",
+ method = "loess", span = 0.225, alpha = 0.75
+ ) +
+ geom_text(aes(x = meanyear, label = city, y = 62.5),
+ family = "Alegreya", angle = 60, hjust = 0
+ ) +
+ labs(
+ x = NULL,
+ y = "Number of compositions",
+ fill = "City"
+ ) +
scale_fill_daniel(palette = "staalmeesters") +
- scale_x_continuous(breaks = seq(1690,1750,10), expand = c(0,0)) +
- scale_y_continuous(limits = c(0,85), breaks = seq(0,60,20), expand = c(0,0)) +
- theme_bach(base_family = "Alegreya", grid = FALSE, ticks = FALSE, axis_title_just = "c") +
+ scale_x_continuous(breaks = seq(1690, 1750, 10), expand = c(0, 0)) +
+ scale_y_continuous(
+ limits = c(0, 85),
+ breaks = seq(0, 60, 20),
+ expand = c(0, 0)
+ ) +
+ theme_bach(
+ base_family = "Alegreya", grid = FALSE,
+ ticks = FALSE, axis_title_just = "c"
+ ) +
theme(
legend.position = "none"
)
@@ -500,12 +608,14 @@ Lastly, just for fun, I created a map.
places_unique <- places |>
distinct(city, .keep_all = TRUE)
-ggplot(places_unique, aes(x = lon, y = lat)) +
+ggplot(places_unique, aes(x = lon, y = lat)) +
borders("world", colour = palette[3], fill = palette[4], alpha = 1) +
geom_point(color = palette[1], size = 4) +
- ggrepel::geom_text_repel(aes(label = city), force = 1, size = 4,
- seed = 2345, point.padding = 0.2,
- family = "Alegreya") +
+ ggrepel::geom_text_repel(aes(label = city),
+ force = 1, size = 4,
+ seed = 2345, point.padding = 0.2,
+ family = "Alegreya"
+ ) +
coord_quickmap(xlim = c(4, 18), ylim = c(48, 55)) +
theme_void()
```
@@ -514,4 +624,4 @@ This was a fun exercise in scraping data and trying out new things with visualiz
## Future plans
-In the future, I hope to do some more in-depth statistical analysis on any of this. Perhaps I'll finally dive into the setting, there are some cool more complex visualization opportunities there. With this I could also make a Shiny app where one can select the voices you are interested in, and it will show you the pieces that are written for that combination of voices, or select the time of the year, and it will return the pieces written for that part of the Christian calendar (i.e. Advent, Epiphany, or Easter). Most importantly, I might actually do some statistics, instead of just visualizing data. Creating nice figures is great fun, but the real interest lies in perfoming adequate statistical tests, though I still need to think about what statistics would be appropriate for this context. Any tips or requests?
\ No newline at end of file
+In the future, I hope to do some more in-depth statistical analysis on any of this. Perhaps I'll finally dive into the setting, there are some cool more complex visualization opportunities there. With this I could also make a Shiny app where one can select the voices you are interested in, and it will show you the pieces that are written for that combination of voices, or select the time of the year, and it will return the pieces written for that part of the Christian calendar (i.e. Advent, Epiphany, or Easter). Most importantly, I might actually do some statistics, instead of just visualizing data. Creating nice figures is great fun, but the real interest lies in perfoming adequate statistical tests, though I still need to think about what statistics would be appropriate for this context. Any tips or requests?
diff --git a/content/blog/2019-analyzing-bach/places.Rdata b/content/blog/2019-analyzing-bach/places.Rdata
deleted file mode 100644
index 721144c..0000000
Binary files a/content/blog/2019-analyzing-bach/places.Rdata and /dev/null differ
diff --git a/content/blog/2019-analyzing-bach/scraped_data.Rdata b/content/blog/2019-analyzing-bach/scraped_data.Rdata
deleted file mode 100644
index aaeb321..0000000
Binary files a/content/blog/2019-analyzing-bach/scraped_data.Rdata and /dev/null differ
diff --git a/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png b/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png
index 0f1411d..5feaf77 100644
Binary files a/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png and b/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png differ
diff --git a/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.md b/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.md
index bd35e87..8290a33 100644
--- a/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.md
+++ b/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.md
@@ -14,13 +14,15 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
+## Introduction
There are many ways to create a Manhattan plot. There's a number of online tools that create Manhattan plots for you, it's implemented in a number of toolboxes that are often used in genetics, and there's a couple of packages for R that can create these plots. However, these options often don't offer the customizability that some people (like me) would want. One of the most flexible ways to plot a Manhattan plot (I know of) is the `{manhattan}` package, but how nice would it be to have full control over the properties of the plot. Therefore, whenever I need to create a Manhattan plot, my preference is to go to the awesome `{ggplot2}` package. In my opinion, it gives me more control over the lay-out and properties of the Manhattan plot, so I thought I'd go through how I go about creating Manhattan plots in R using the `{ggplot2}` package. I've tried this code on GWAS summary statistics from several sources, and it works for a bunch of them. Because data can look somewhat different, I'll describe the concept behind some of the code, as to show what my reasoning is behind each step. One thing I should point out is that it's probably best to run this code on a computer that is a little bit powerful, since it will need to deal with an enormous amount of SNPs, that will create massive dataframes and plot objects.
-### Import data into R
+## Import data into R
The first step, as always, is to load the packages we need. I personally prefer to use as little packages as possible and write most of the code myself, because that gives me total control over what happens to my data. However, there are some packages (in particular some of the packages developed by Hadley Wickham) that are very powerful. So, all code described below depends on one of two packages, the `{tidyverse}` package, which includes the `{ggplot2}` and `{dplyr}` package. Next, I load the file that contains the GWAS summary statistics. Different tools use different file formats. The file I use is the output from PLINK with the `--meta-analysis` flag. This file can simple be loaded as a table. Here I use a function from our own `{normentR}` package, called `simulateGWAS()`, which does as the name suggest, and simulate the output from a GWAS analysis.
@@ -33,7 +35,7 @@ library(normentR)
``` r
set.seed(2404)
-gwas_data_load <- simulateGWAS(nSNPs = 1e6, nSigCols = 3) |>
+gwas_data_load <- simulateGWAS(nSNPs = 1e6, nSigCols = 3) |>
janitor::clean_names()
```
@@ -55,64 +57,84 @@ This will create a dataframe with as many rows as there are SNPs in the summary
A vast majority of the datapoints will overlap in the non-significant region of the Manhattan plot, these data points are not particularly informative, and it's possible to select a random number of SNPs in this region to make it less computationally heavy. The data I used here does not have such a large volume, so I only needed to filter a small number of SNPs (10% in this case).
``` r
-sig_data <- gwas_data_load |>
+sig_data <- gwas_data_load |>
subset(p < 0.05)
-notsig_data <- gwas_data_load |>
+
+notsig_data <- gwas_data_load |>
subset(p >= 0.05) |>
- group_by(chr) |>
+ group_by(chr) |>
sample_frac(0.1)
+
gwas_data <- bind_rows(sig_data, notsig_data)
```
-### Preparing the data
+## Preparing the data
Since the only columns we have indicating position are the chromosome number and the base pair position of the SNP on that chromosome, we want to combine those so that we have one column with position that we can use for the x-axis. So, what we want to do is to create a column with cumulative base pair position in a way that puts the SNPs on the first chromosome first, and the SNPs on chromosome 22 last. I create a data frame frame called `data_cum` (for cumulative), which selects the largest position for each chromosome, and then calculates the cumulative sum of those. Since we don't need to add anything to the first chromosome, we move everything one row down (using the `lag()` function). We then merge this data frame with the original dataframe and calculate a the cumulative basepair position for each SNP by adding the relative position and the adding factor together. This will create a column (here called `bp_cum`) in which the relative base pair position is the position as if it was stitched together. This code is shown below:
``` r
-data_cum <- gwas_data |>
- group_by(chr) |>
- summarise(max_bp = max(bp)) |>
- mutate(bp_add = lag(cumsum(max_bp), default = 0)) |>
+data_cum <- gwas_data |>
+ group_by(chr) |>
+ summarise(max_bp = max(bp)) |>
+ mutate(bp_add = lag(cumsum(max_bp), default = 0)) |>
select(chr, bp_add)
-gwas_data <- gwas_data |>
- inner_join(data_cum, by = "chr") |>
+gwas_data <- gwas_data |>
+ inner_join(data_cum, by = "chr") |>
mutate(bp_cum = bp + bp_add)
```
-When this is done, the next thing I want to do is to get a couple of parameters that I'll use for the plot later. First, I want the centre position of each chromosome. This position I'll use later to place the labels on the x-axis of the Manhattan plot neatly in the middle of each chromosome. In order to get this position, I'll pipe the `gwas_data` dataframe into this powerful `{dplyr}` function which I then ask to calculate the difference between the maximum and minimum cumulative base pair position for each chromosome and divide it by two to get the middle of each chromosome. I also want to set the limit of the y-axis, as not to cut off any highly significant SNPs. If you want to compare multiple GWAS statistics, then I highly recommend to hard code the limit of the y-axis, and then explore the data beforehand to make sure your chosen limit does not cut off any SNPs. Since the y-axis will be log transformed, we need an integer that is lower than the largest negative exponent. But since the y-axis will be linear and positive, I transform the largest exponent to positive and add 2, to give some extra space on the top edge of the plot. When plotting, I actually convert it back to a log scale, but it's a bit easier to add a constant to it by transforming it to a regular integer first. Then, we also want to indicate the significance threshold, I prefer to save this in a variable. Here, I choose to get a Bonferroni-corrected threshold, which is 0.05 divided by the number of SNPs in the summary statistics. I believe many scientists will use the "standard" threshold of 0.05 divided by 1e-6, which is 5e-8. However, in the data I had I believed it to be best to use the Bonferroni-corrected threshold since the sample encompassed different populations, and because it contained less than a million SNPs were used in the association testing, which would make a standard correction overly conservative. These three parameters were calculated as follows:
+When this is done, the next thing I want to do is to get a couple of parameters that I'll use for the plot later. First, I want the centre position of each chromosome. This position I'll use later to place the labels on the x-axis of the Manhattan plot neatly in the middle of each chromosome. In order to get this position, I'll pipe the `gwas_data` dataframe into this powerful `{dplyr}` function which I then ask to calculate the difference between the maximum and minimum cumulative base pair position for each chromosome and divide it by two to get the middle of each chromosome. I also want to set the limit of the y-axis, as not to cut off any highly significant SNPs. If you want to compare multiple GWAS statistics, then I highly recommend to hard code the limit of the y-axis, and then explore the data beforehand to make sure your chosen limit does not cut off any SNPs. Since the y-axis will be log transformed, we need an integer that is lower than the largest negative exponent. But since the y-axis will be linear and positive, I transform the largest exponent to positive and add 2, to give some extra space on the top edge of the plot. When plotting, I actually convert it back to a log scale, but it's a bit easier to add a constant to it by transforming it to a regular integer first.
+
+{{< sidenote br="5em" >}}
+Note that the 5e-8 threshold [has its own issues](https://doi.org/10.1038%2Fejhg.2015.269)
+{{< /sidenote >}}
+
+Then, we also want to indicate the significance threshold, I prefer to save this in a variable. Here, I choose to get a Bonferroni-corrected threshold, which is 0.05 divided by the number of SNPs in the summary statistics. Usually, I would use the "default" threshold of 0.05 divided by 1e-6 which is 5e-8. However, in the data I had I believed it to be best to use the Bonferroni-corrected threshold to be a little bit more conservative given the dataset I had. These three parameters were calculated as follows:
``` r
-axis_set <- gwas_data |>
- group_by(chr) |>
+axis_set <- gwas_data |>
+ group_by(chr) |>
summarize(center = mean(bp_cum))
-ylim <- gwas_data |>
- filter(p == min(p)) |>
- mutate(ylim = abs(floor(log10(p))) + 2) |>
+ylim <- gwas_data |>
+ filter(p == min(p)) |>
+ mutate(ylim = abs(floor(log10(p))) + 2) |>
pull(ylim)
-sig <- 5e-8
+sig <- 0.05 / nrow(gwas_data_load)
```
-### Plotting the data
+## Plotting the data
Finally, we're ready to plot the data. As promised, I use the `ggplot()` function for this. I build this up like I would any other `ggplot` object, each SNP will be one point on the plot. Each SNP will be colored based on the chromosome. I manually set the colors, add the labels based on the definitions I determined earlier, and set the y limits to the limit calculated before as well. I add a horizontal dashed line indicating the significance threshold. In Manhattan plots we really don't need a grid, all that would be nice are horizontal grid lines, so I keep those but remove vertical lines. Manhattan plots can be a bit intimidating, so I prefer them as minimal as possible. Shown below is the code I use to create the plot and to save the plot as an image.
``` r
-manhplot <- ggplot(gwas_data, aes(x = bp_cum, y = -log10(p),
- color = as_factor(chr), size = -log10(p))) +
- geom_hline(yintercept = -log10(sig), color = "grey40", linetype = "dashed") +
+manhplot <- ggplot(gwas_data, aes(
+ x = bp_cum, y = -log10(p),
+ color = as_factor(chr), size = -log10(p)
+)) +
+ geom_hline(
+ yintercept = -log10(sig), color = "grey40",
+ linetype = "dashed"
+ ) +
geom_point(alpha = 0.75) +
- scale_x_continuous(label = axis_set$chr, breaks = axis_set$center) +
- scale_y_continuous(expand = c(0,0), limits = c(0, ylim)) +
- scale_color_manual(values = rep(c("#276FBF", "#183059"),
- unique(length(axis_set$chr)))) +
- scale_size_continuous(range = c(0.5,3)) +
- labs(x = NULL,
- y = "-log10(p)") +
+ scale_x_continuous(
+ label = axis_set$chr,
+ breaks = axis_set$center
+ ) +
+ scale_y_continuous(expand = c(0, 0), limits = c(0, ylim)) +
+ scale_color_manual(values = rep(
+ c("#276FBF", "#183059"),
+ unique(length(axis_set$chr))
+ )) +
+ scale_size_continuous(range = c(0.5, 3)) +
+ labs(
+ x = NULL,
+ y = "-log10(p)"
+ ) +
theme_minimal() +
- theme(
+ theme(
legend.position = "none",
panel.grid.major.x = element_blank(),
panel.grid.minor.x = element_blank(),
diff --git a/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.qmd b/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.qmd
index 3ad0694..2ebc8e0 100644
--- a/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.qmd
+++ b/content/blog/2019-how-i-create-manhattan-plots-using-ggplot/index.qmd
@@ -14,12 +14,16 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
+## Introduction
+
There are many ways to create a Manhattan plot. There's a number of online tools that create Manhattan plots for you, it's implemented in a number of toolboxes that are often used in genetics, and there's a couple of packages for R that can create these plots. However, these options often don't offer the customizability that some people (like me) would want. One of the most flexible ways to plot a Manhattan plot (I know of) is the `{manhattan}` package, but how nice would it be to have full control over the properties of the plot. Therefore, whenever I need to create a Manhattan plot, my preference is to go to the awesome `{ggplot2}` package. In my opinion, it gives me more control over the lay-out and properties of the Manhattan plot, so I thought I'd go through how I go about creating Manhattan plots in R using the `{ggplot2}` package. I've tried this code on GWAS summary statistics from several sources, and it works for a bunch of them. Because data can look somewhat different, I'll describe the concept behind some of the code, as to show what my reasoning is behind each step. One thing I should point out is that it's probably best to run this code on a computer that is a little bit powerful, since it will need to deal with an enormous amount of SNPs, that will create massive dataframes and plot objects.
-### Import data into R
+## Import data into R
+
The first step, as always, is to load the packages we need. I personally prefer to use as little packages as possible and write most of the code myself, because that gives me total control over what happens to my data. However, there are some packages (in particular some of the packages developed by Hadley Wickham) that are very powerful. So, all code described below depends on one of two packages, the `{tidyverse}` package, which includes the `{ggplot2}` and `{dplyr}` package. Next, I load the file that contains the GWAS summary statistics. Different tools use different file formats. The file I use is the output from PLINK with the `--meta-analysis` flag. This file can simple be loaded as a table. Here I use a function from our own `{normentR}` package, called `simulateGWAS()`, which does as the name suggest, and simulate the output from a GWAS analysis.
```{r}
@@ -36,7 +40,7 @@ library(normentR)
set.seed(2404)
-gwas_data_load <- simulateGWAS(nSNPs = 1e6, nSigCols = 3) |>
+gwas_data_load <- simulateGWAS(nSNPs = 1e6, nSigCols = 3) |>
janitor::clean_names()
```
@@ -47,68 +51,90 @@ A vast majority of the datapoints will overlap in the non-significant region of
```{r}
#| label: reduce-size
-sig_data <- gwas_data_load |>
+sig_data <- gwas_data_load |>
subset(p < 0.05)
-notsig_data <- gwas_data_load |>
+
+notsig_data <- gwas_data_load |>
subset(p >= 0.05) |>
- group_by(chr) |>
+ group_by(chr) |>
sample_frac(0.1)
+
gwas_data <- bind_rows(sig_data, notsig_data)
```
-### Preparing the data
+## Preparing the data
+
Since the only columns we have indicating position are the chromosome number and the base pair position of the SNP on that chromosome, we want to combine those so that we have one column with position that we can use for the x-axis. So, what we want to do is to create a column with cumulative base pair position in a way that puts the SNPs on the first chromosome first, and the SNPs on chromosome 22 last. I create a data frame frame called `data_cum` (for cumulative), which selects the largest position for each chromosome, and then calculates the cumulative sum of those. Since we don't need to add anything to the first chromosome, we move everything one row down (using the `lag()` function). We then merge this data frame with the original dataframe and calculate a the cumulative basepair position for each SNP by adding the relative position and the adding factor together. This will create a column (here called `bp_cum`) in which the relative base pair position is the position as if it was stitched together. This code is shown below:
```{r}
#| label: cumulative-bp
-data_cum <- gwas_data |>
- group_by(chr) |>
- summarise(max_bp = max(bp)) |>
- mutate(bp_add = lag(cumsum(max_bp), default = 0)) |>
+data_cum <- gwas_data |>
+ group_by(chr) |>
+ summarise(max_bp = max(bp)) |>
+ mutate(bp_add = lag(cumsum(max_bp), default = 0)) |>
select(chr, bp_add)
-gwas_data <- gwas_data |>
- inner_join(data_cum, by = "chr") |>
+gwas_data <- gwas_data |>
+ inner_join(data_cum, by = "chr") |>
mutate(bp_cum = bp + bp_add)
```
-When this is done, the next thing I want to do is to get a couple of parameters that I'll use for the plot later. First, I want the centre position of each chromosome. This position I'll use later to place the labels on the x-axis of the Manhattan plot neatly in the middle of each chromosome. In order to get this position, I'll pipe the `gwas_data` dataframe into this powerful `{dplyr}` function which I then ask to calculate the difference between the maximum and minimum cumulative base pair position for each chromosome and divide it by two to get the middle of each chromosome. I also want to set the limit of the y-axis, as not to cut off any highly significant SNPs. If you want to compare multiple GWAS statistics, then I highly recommend to hard code the limit of the y-axis, and then explore the data beforehand to make sure your chosen limit does not cut off any SNPs. Since the y-axis will be log transformed, we need an integer that is lower than the largest negative exponent. But since the y-axis will be linear and positive, I transform the largest exponent to positive and add 2, to give some extra space on the top edge of the plot. When plotting, I actually convert it back to a log scale, but it's a bit easier to add a constant to it by transforming it to a regular integer first. Then, we also want to indicate the significance threshold, I prefer to save this in a variable. Here, I choose to get a Bonferroni-corrected threshold, which is 0.05 divided by the number of SNPs in the summary statistics. I believe many scientists will use the "standard" threshold of 0.05 divided by 1e-6, which is 5e-8. However, in the data I had I believed it to be best to use the Bonferroni-corrected threshold since the sample encompassed different populations, and because it contained less than a million SNPs were used in the association testing, which would make a standard correction overly conservative. These three parameters were calculated as follows:
+When this is done, the next thing I want to do is to get a couple of parameters that I'll use for the plot later. First, I want the centre position of each chromosome. This position I'll use later to place the labels on the x-axis of the Manhattan plot neatly in the middle of each chromosome. In order to get this position, I'll pipe the `gwas_data` dataframe into this powerful `{dplyr}` function which I then ask to calculate the difference between the maximum and minimum cumulative base pair position for each chromosome and divide it by two to get the middle of each chromosome. I also want to set the limit of the y-axis, as not to cut off any highly significant SNPs. If you want to compare multiple GWAS statistics, then I highly recommend to hard code the limit of the y-axis, and then explore the data beforehand to make sure your chosen limit does not cut off any SNPs. Since the y-axis will be log transformed, we need an integer that is lower than the largest negative exponent. But since the y-axis will be linear and positive, I transform the largest exponent to positive and add 2, to give some extra space on the top edge of the plot. When plotting, I actually convert it back to a log scale, but it's a bit easier to add a constant to it by transforming it to a regular integer first.
+
+{{{< sidenote br="5em" >}}}
+Note that the 5e-8 threshold [has its own issues](https://doi.org/10.1038%2Fejhg.2015.269)
+{{{< /sidenote >}}}
+
+Then, we also want to indicate the significance threshold, I prefer to save this in a variable. Here, I choose to get a Bonferroni-corrected threshold, which is 0.05 divided by the number of SNPs in the summary statistics. Usually, I would use the "default" threshold of 0.05 divided by 1e-6 which is 5e-8. However, in the data I had I believed it to be best to use the Bonferroni-corrected threshold to be a little bit more conservative given the dataset I had. These three parameters were calculated as follows:
```{r}
#| label: set-axes
-axis_set <- gwas_data |>
- group_by(chr) |>
+axis_set <- gwas_data |>
+ group_by(chr) |>
summarize(center = mean(bp_cum))
-ylim <- gwas_data |>
- filter(p == min(p)) |>
- mutate(ylim = abs(floor(log10(p))) + 2) |>
+ylim <- gwas_data |>
+ filter(p == min(p)) |>
+ mutate(ylim = abs(floor(log10(p))) + 2) |>
pull(ylim)
-sig <- 5e-8
+sig <- 0.05 / nrow(gwas_data_load)
```
-### Plotting the data
+## Plotting the data
+
Finally, we're ready to plot the data. As promised, I use the `ggplot()` function for this. I build this up like I would any other `ggplot` object, each SNP will be one point on the plot. Each SNP will be colored based on the chromosome. I manually set the colors, add the labels based on the definitions I determined earlier, and set the y limits to the limit calculated before as well. I add a horizontal dashed line indicating the significance threshold. In Manhattan plots we really don't need a grid, all that would be nice are horizontal grid lines, so I keep those but remove vertical lines. Manhattan plots can be a bit intimidating, so I prefer them as minimal as possible. Shown below is the code I use to create the plot and to save the plot as an image.
```{r}
#| label: create-plot
-manhplot <- ggplot(gwas_data, aes(x = bp_cum, y = -log10(p),
- color = as_factor(chr), size = -log10(p))) +
- geom_hline(yintercept = -log10(sig), color = "grey40", linetype = "dashed") +
+manhplot <- ggplot(gwas_data, aes(
+ x = bp_cum, y = -log10(p),
+ color = as_factor(chr), size = -log10(p)
+)) +
+ geom_hline(
+ yintercept = -log10(sig), color = "grey40",
+ linetype = "dashed"
+ ) +
geom_point(alpha = 0.75) +
- scale_x_continuous(label = axis_set$chr, breaks = axis_set$center) +
- scale_y_continuous(expand = c(0,0), limits = c(0, ylim)) +
- scale_color_manual(values = rep(c("#276FBF", "#183059"),
- unique(length(axis_set$chr)))) +
- scale_size_continuous(range = c(0.5,3)) +
- labs(x = NULL,
- y = "-log10(p)") +
+ scale_x_continuous(
+ label = axis_set$chr,
+ breaks = axis_set$center
+ ) +
+ scale_y_continuous(expand = c(0, 0), limits = c(0, ylim)) +
+ scale_color_manual(values = rep(
+ c("#276FBF", "#183059"),
+ unique(length(axis_set$chr))
+ )) +
+ scale_size_continuous(range = c(0.5, 3)) +
+ labs(
+ x = NULL,
+ y = "-log10(p)"
+ ) +
theme_minimal() +
- theme(
+ theme(
legend.position = "none",
panel.grid.major.x = element_blank(),
panel.grid.minor.x = element_blank(),
diff --git a/content/blog/2019-how-i-plot-erps-in-r/data.RData b/content/blog/2019-how-i-plot-erps-in-r/data.RData
deleted file mode 100644
index 33d2dfd..0000000
Binary files a/content/blog/2019-how-i-plot-erps-in-r/data.RData and /dev/null differ
diff --git a/content/blog/2019-how-i-plot-erps-in-r/times.txt b/content/blog/2019-how-i-plot-erps-in-r/data/times.txt
similarity index 100%
rename from content/blog/2019-how-i-plot-erps-in-r/times.txt
rename to content/blog/2019-how-i-plot-erps-in-r/data/times.txt
diff --git a/content/blog/2019-how-i-plot-erps-in-r/index.markdown_strict_files/figure-markdown_strict/erp-plot-1.png b/content/blog/2019-how-i-plot-erps-in-r/index.markdown_strict_files/figure-markdown_strict/erp-plot-1.png
index ec7d191..432cbf2 100644
Binary files a/content/blog/2019-how-i-plot-erps-in-r/index.markdown_strict_files/figure-markdown_strict/erp-plot-1.png and b/content/blog/2019-how-i-plot-erps-in-r/index.markdown_strict_files/figure-markdown_strict/erp-plot-1.png differ
diff --git a/content/blog/2019-how-i-plot-erps-in-r/index.md b/content/blog/2019-how-i-plot-erps-in-r/index.md
index f29d7af..a10799f 100644
--- a/content/blog/2019-how-i-plot-erps-in-r/index.md
+++ b/content/blog/2019-how-i-plot-erps-in-r/index.md
@@ -15,6 +15,8 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
## Introduction
@@ -32,28 +34,32 @@ library(normentR)
Since I cannot share participants' data, I used an open EEG dataset downloaded here, this data comes from a psychophysics group of 5 participants with 2 conditions. It came in the EEGLAB format, same as my own data. The first step is to take the data out of MATLAB and take it to a format that can be easily understood by R. The most convenient way I thought of was to take the `EEG.data` field, transform it into a two-dimensional metrix and store it in a .csv file.
-If you have a large amount of participants, I can recommend to only extract data from the channels of interest or the conditions of interest. One can make one file per channel or participant, or one large file that contains everything. I usually choose the latter, and that's what I'll work with here. So my file looks as follows: one column with the channel, one column with the ID, one with the condition (or trigger). If I'm doing a between-groups analysis, I'll also have a column with the group. All the other columns are the amplitudes with across the timepoints.
+If you have a large amount of participants, I can recommend to only extract data from the channels of interest or the conditions of interest. One can make one file per channel or participant, or one large file that contains everything. I usually choose the latter, and that's what I'll work with here. So my file looks as follows: one column with the channel, one column with the ID, one with the condition (or trigger). If I'm doing a between-groups analysis, I'll also have a column with the group. All the other columns are the amplitudes with across the timepoints. I also have a file with the timepoints for each value. i.e. with epoch of 500 milliseconds ranging from 100 milliseconds pre-stimulus to 400 milliseconds post-stimulus, all the timepoints according to the sampling rate are the values in this file. It is basically nothing more than a print of the values in the `EEG.times` field from the EEGLAB dataset. I'll load this list of time points here also.
``` r
-data <- read_delim("AllChannels_ERP.txt", delim = "\t", col_names = FALSE)
-```
+data <- read_delim("./data/all_channels_erp.txt",
+ delim = "\t", col_names = FALSE
+)
-I also have a file with the timepoints for each value. i.e. with epoch of 500 milliseconds ranging from 100 milliseconds pre-stimulus to 400 milliseconds post-stimulus, all the timepoints according to the sampling rate are the values in this file. It is basically nothing more than a print of the values in the `EEG.times` field from the EEGLAB dataset.
+times <- read_table("./data/times.txt", col_names = FALSE)
+```
-Since I didn't include any headers in my file, I rename them here. I give the the identifying columns their appropriate names, and for the amplitudes, I attach the values from the `times` variable as names to these columns, so -100 will be one column, -99 will be another, and so on.
+{{< sidenote >}}
+The `janitor` package helps cleaning up column names, in this instance it converts all default columns (e.g. `V1`) to lowercase (i.e. `v1`)
+{{< /sidenote >}}
``` r
-ERPdata <- data |>
- rename(Channel = V1,
- ID = V2,
- Condition = V3) |>
- mutate(ID = factor(ID),
- Condition = factor(Condition))
-
-oldnames <- sprintf("V%s", 1:ncol(times) + 3)
-
-ERPdata <- ERPdata |>
- rename_at(vars(all_of(oldnames)), ~ as.character(times))
+erp_data <- data |>
+ janitor::clean_names() |>
+ rename(
+ channel = v1,
+ id = v2,
+ condition = v3
+ ) |>
+ mutate(
+ id = as_factor(id),
+ condition = as_factor(condition)
+ )
```
## Preparing the data
@@ -61,43 +67,57 @@ ERPdata <- ERPdata |>
Then I specify a variable with the channels of interest. These will be the channels I'll average across later.
``` r
-coi <- c("P1", "P2", "Pz", "P3", "P4", "PO3", "PO4", "POz");
+coi <- c("P1", "P2", "Pz", "P3", "P4", "PO3", "PO4", "POz")
```
-Then I calculate the means across channels and conditions. This goes in two steps. First I'll select only the channels of interest, then I'll group by ID, condition, and channel. And then calculate the average of every other column, in this case column 4 to the end of the file. Then I'll do the same, except now I'll group by ID and condition. So then we have one average ERP for every condition in all participants.
+Then I calculate the means across channels and conditions. This goes in two steps. First I'll select only the channels of interest, then I'll group by ID, condition, and channel. And then calculate the average of every other column, in this case all columns starting with "v". Then I'll do the same, except now I'll group by ID and condition. So then we have one average ERP for every condition in all participants.
+
+{{< sidenote >}}
+The `summarise()` function will throw a warning about the grouping variable, this can be silenced by setting `.groups = "drop"`
+{{< /sidenote >}}
``` r
-ERPdata_mChan <- ERPdata |>
- filter(Channel %in% coi) |>
- group_by(ID,Condition,Channel) %>%
- summarise_at(vars(names(.)[4:ncol(.)]), list(~ mean(., na.rm = TRUE))) |>
+erp_data_chan_mean <- erp_data |>
+ filter(channel %in% coi) |>
+ group_by(id, condition, channel) |>
+ summarise(across(starts_with("v"), ~ mean(.x, na.rm = TRUE))) |>
ungroup()
-ERPdata_mCond <- ERPdata_mChan |>
- group_by(ID,Condition) %>%
- summarise_at(vars(names(.)[4:ncol(.)]), list(~ mean(., na.rm = TRUE))) |>
+erp_data_cond_mean <- erp_data_chan_mean |>
+ group_by(id, condition) |>
+ summarise(across(starts_with("v"), ~ mean(.x, na.rm = TRUE))) |>
ungroup()
-MeanERPs <- ERPdata_mCond
+mean_erp <- erp_data_cond_mean
```
## Calculate grand average and confidence interval
-The next piece of code calculates the grand average. I will also calculate the confidence interval and then transform it from the interval relative to the mean to the absolute values representing the upper and lower boundaries of the confidence interval. Here I use a confidence interval of 95%. We first transform from wide to long format using the `pivot_longer()` function from the `{tidyr}` package. Then we convert the (now character) `Time` variable to numeric. Then we will calculate the average amplitude per time point. Then using the `CI()` function from the `{Rmisc}` package, we calculate the upper and lower bounds of the confidence interval.
+The next piece of code calculates the grand average. I will also add the time for each timepoint in milliseconds from the "times.txt" file we loaded earlier. Afterwards, I will alculate the confidence interval and then transform it from the interval relative to the mean to the absolute values representing the upper and lower boundaries of the confidence interval. Here I use a confidence interval of 95%. We first transform from wide to long format using the `pivot_longer()` function from the `{tidyr}` package. I merge the data frame containing the times to the long data frame with the mean ERP so that we have a column with numerical time points. Then we calculate the average amplitude per time point. Then using the `CI()` function from the `{Rmisc}` package, we calculate the upper and lower bounds of the confidence interval and add each as a separate column in the data frame.
``` r
-ERP_plotdata <- MeanERPs |>
- pivot_longer(-c(ID,Condition), names_to = "Time", values_to = "Amplitude") |>
- mutate(Time = as.numeric(Time)) |>
- group_by(Condition,Time) |>
- summarise(Mean_Amplitude = mean(Amplitude),
- CIlower = Rmisc::CI(Amplitude, ci = 0.95)["lower"],
- CIupper = Rmisc::CI(Amplitude, ci = 0.95)["upper"])
+times <- times |>
+ pivot_longer(
+ cols = everything(),
+ names_to = "index", values_to = "time"
+ ) |>
+ mutate(timepoint = str_glue("v{row_number() + 3}")) |>
+ select(-index)
+
+erp_plotdata <- mean_erp |>
+ pivot_longer(
+ cols = -c(id, condition),
+ names_to = "timepoint", values_to = "amplitude"
+ ) |>
+ inner_join(times, by = "timepoint") |>
+ group_by(condition, time) |>
+ summarise(
+ mean_amplitude = mean(amplitude),
+ ci_lower = Rmisc::CI(amplitude, ci = 0.95)["lower"],
+ ci_upper = Rmisc::CI(amplitude, ci = 0.95)["upper"]
+ )
```
- `summarise()` has grouped output by 'Condition'. You can override using the
- `.groups` argument.
-
## Preparing to plot
Before we can start plotting, I just wanted to share one piece of code I found on StackOverflow. The question there was to move the x-axis and y-axis line towards 0, rather than the edge of the plot. You can find the question (and answers) here. I combined two answers into a function that moves both the y- and the x-axis to 0. It is my personal preference to have a line indicating 0. This makes the plots easier to read and looks prettier too, but of course this is subjective. Alternatively we could also add a `geom_hline()` and `geom_vline()`, both with intercept at 0, and turn the axes off (as default in `theme_norment()`. This will still give you the lines at x=0 and y=0 but will keep the axis labels at 0.
@@ -111,30 +131,31 @@ After running the chunk below, we have a beautiful ERP with a nice confidence in
``` r
colors <- norment_pal(palette = "logo")(2)
-ERPplot <- ggplot(ERP_plotdata, aes(x = Time, y = Mean_Amplitude,
- colour = Condition, group = Condition)) +
- geom_ribbon(aes(ymin = CIlower, ymax = CIupper, fill = Condition),
- alpha = 0.1, linetype = 0) +
- geom_line(size = 0.75) +
- scale_color_manual(values = colors) +
- scale_fill_manual(values = colors) +
- scale_x_continuous(breaks = c(seq(-2000,2000,500))) +
- scale_y_continuous(breaks = c(seq(-12,-1,2), seq(2,12,2))) +
+erp_plot <- ggplot(erp_plotdata, aes(
+ x = time, y = mean_amplitude,
+ colour = condition, group = condition
+)) +
+ geom_ribbon(aes(ymin = ci_lower, ymax = ci_upper, fill = condition),
+ alpha = 0.1, linetype = 0
+ ) +
+ geom_line(linewidth = 0.75) +
+ scale_color_manual(values = colors) +
+ scale_fill_manual(values = colors) +
+ scale_x_continuous(breaks = c(seq(-2000, 2000, 500))) +
+ scale_y_continuous(breaks = c(seq(-12, -1, 2), seq(2, 12, 2))) +
coord_cartesian() +
- labs(x = "Time (ms)",
- y = "Amplitude (µV)") +
+ labs(
+ x = "Time (ms)",
+ y = "Amplitude (µV)"
+ ) +
theme_norment(ticks = TRUE, grid = FALSE) +
theme(
- legend.position = c(0.9,0.1),
+ legend.position = c(0.9, 0.1),
axis.text.x = element_text(vjust = -0.1)
)
-```
-
- Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
- ℹ Please use `linewidth` instead.
-
-``` r
-shift_axes(ERPplot, x = 0, y = 0)
+shift_axes(erp_plot, x = 0, y = 0)
```
+
+**EDIT (2023-10-30)**: In the process of making some general updates to this site, I also revisited some of the code here. I improved the standard somewhat from when I first wrote this post in 2019 and brought it up to the code standards of 2023. The old version is of course available on GitHub.
diff --git a/content/blog/2019-how-i-plot-erps-in-r/index.qmd b/content/blog/2019-how-i-plot-erps-in-r/index.qmd
index aebeb37..8cc074a 100644
--- a/content/blog/2019-how-i-plot-erps-in-r/index.qmd
+++ b/content/blog/2019-how-i-plot-erps-in-r/index.qmd
@@ -15,6 +15,8 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
## Introduction
@@ -35,57 +37,63 @@ library(normentR)
Since I cannot share participants' data, I used an open EEG dataset downloaded [here](https://sccn.ucsd.edu/~arno/fam2data/publicly_available_EEG_data.html){target="_blank"}, this data comes from a psychophysics group of 5 participants with 2 conditions. It came in the EEGLAB format, same as my own data. The first step is to take the data out of MATLAB and take it to a format that can be easily understood by R. The most convenient way I thought of was to take the `EEG.data` field, transform it into a two-dimensional metrix and store it in a .csv file.
-If you have a large amount of participants, I can recommend to only extract data from the channels of interest or the conditions of interest. One can make one file per channel or participant, or one large file that contains everything. I usually choose the latter, and that's what I'll work with here. So my file looks as follows: one column with the channel, one column with the ID, one with the condition (or trigger). If I'm doing a between-groups analysis, I'll also have a column with the group. All the other columns are the amplitudes with across the timepoints.
+If you have a large amount of participants, I can recommend to only extract data from the channels of interest or the conditions of interest. One can make one file per channel or participant, or one large file that contains everything. I usually choose the latter, and that's what I'll work with here. So my file looks as follows: one column with the channel, one column with the ID, one with the condition (or trigger). If I'm doing a between-groups analysis, I'll also have a column with the group. All the other columns are the amplitudes with across the timepoints. I also have a file with the timepoints for each value. i.e. with epoch of 500 milliseconds ranging from 100 milliseconds pre-stimulus to 400 milliseconds post-stimulus, all the timepoints according to the sampling rate are the values in this file. It is basically nothing more than a print of the values in the `EEG.times` field from the EEGLAB dataset. I'll load this list of time points here also.
```{r}
#| label: read-data
#| eval: false
-data <- read_delim("AllChannels_ERP.txt", delim = "\t", col_names = FALSE)
-```
+data <- read_delim("./data/all_channels_erp.txt",
+ delim = "\t", col_names = FALSE
+)
-I also have a file with the timepoints for each value. i.e. with epoch of 500 milliseconds ranging from 100 milliseconds pre-stimulus to 400 milliseconds post-stimulus, all the timepoints according to the sampling rate are the values in this file. It is basically nothing more than a print of the values in the `EEG.times` field from the EEGLAB dataset.
+times <- read_table("./data/times.txt", col_names = FALSE)
+```
```{r}
#| label: save-data
#| echo: false
#| eval: false
-save(data, file = "data.RData")
+write_rds(data, file = "./data/data.rds")
```
```{r}
#| label: load-data
#| echo: false
+#| message: false
-load("data.RData")
-times <- read.table("times.txt")
+data <- read_rds("./data/data.rds")
+
+times <- read_table("./data/times.txt", col_names = FALSE)
```
-Since I didn't include any headers in my file, I rename them here. I give the the identifying columns their appropriate names, and for the amplitudes, I attach the values from the `times` variable as names to these columns, so -100 will be one column, -99 will be another, and so on.
+{{{< sidenote >}}}
+The `janitor` package helps cleaning up column names, in this instance it converts all default columns (e.g. `V1`) to lowercase (i.e. `v1`)
+{{{< /sidenote >}}}
```{r}
#| label: prep-data
-ERPdata <- data |>
- rename(Channel = V1,
- ID = V2,
- Condition = V3) |>
- mutate(ID = factor(ID),
- Condition = factor(Condition))
-
-oldnames <- sprintf("V%s", 1:ncol(times) + 3)
-
-ERPdata <- ERPdata |>
- rename_at(vars(all_of(oldnames)), ~ as.character(times))
+erp_data <- data |>
+ janitor::clean_names() |>
+ rename(
+ channel = v1,
+ id = v2,
+ condition = v3
+ ) |>
+ mutate(
+ id = as_factor(id),
+ condition = as_factor(condition)
+ )
```
```{r}
#| label: remove-empty-col
#| echo: false
-ERPdata <- ERPdata |>
- select(-V824)
+erp_data <- erp_data |>
+ select_if(~ !all(is.na(.)))
```
## Preparing the data
@@ -95,50 +103,70 @@ Then I specify a variable with the channels of interest. These will be the chann
```{r}
#| label: set-coi
-coi <- c("P1", "P2", "Pz", "P3", "P4", "PO3", "PO4", "POz");
+coi <- c("P1", "P2", "Pz", "P3", "P4", "PO3", "PO4", "POz")
```
-Then I calculate the means across channels and conditions. This goes in two steps. First I'll select only the channels of interest, then I'll group by ID, condition, and channel. And then calculate the average of every other column, in this case column 4 to the end of the file. Then I'll do the same, except now I'll group by ID and condition. So then we have one average ERP for every condition in all participants.
+Then I calculate the means across channels and conditions. This goes in two steps. First I'll select only the channels of interest, then I'll group by ID, condition, and channel. And then calculate the average of every other column, in this case all columns starting with "v". Then I'll do the same, except now I'll group by ID and condition. So then we have one average ERP for every condition in all participants.
+
+{{{< sidenote >}}}
+The `summarise()` function will throw a warning about the grouping variable, this can be silenced by setting `.groups = "drop"`
+{{{< /sidenote >}}}
```{r}
#| label: calculate-grand-averages
+#| warning: false
-ERPdata_mChan <- ERPdata |>
- filter(Channel %in% coi) |>
- group_by(ID,Condition,Channel) %>%
- summarise_at(vars(names(.)[4:ncol(.)]), list(~ mean(., na.rm = TRUE))) |>
+erp_data_chan_mean <- erp_data |>
+ filter(channel %in% coi) |>
+ group_by(id, condition, channel) |>
+ summarise(across(starts_with("v"), ~ mean(.x, na.rm = TRUE))) |>
ungroup()
-ERPdata_mCond <- ERPdata_mChan |>
- group_by(ID,Condition) %>%
- summarise_at(vars(names(.)[4:ncol(.)]), list(~ mean(., na.rm = TRUE))) |>
+erp_data_cond_mean <- erp_data_chan_mean |>
+ group_by(id, condition) |>
+ summarise(across(starts_with("v"), ~ mean(.x, na.rm = TRUE))) |>
ungroup()
-MeanERPs <- ERPdata_mCond
+mean_erp <- erp_data_cond_mean
```
## Calculate grand average and confidence interval
-The next piece of code calculates the grand average. I will also calculate the confidence interval and then transform it from the interval relative to the mean to the absolute values representing the upper and lower boundaries of the confidence interval. Here I use a confidence interval of 95%. We first transform from wide to long format using the `pivot_longer()` function from the `{tidyr}` package. Then we convert the (now character) `Time` variable to numeric. Then we will calculate the average amplitude per time point. Then using the `CI()` function from the `{Rmisc}` package, we calculate the upper and lower bounds of the confidence interval.
+The next piece of code calculates the grand average. I will also add the time for each timepoint in milliseconds from the "times.txt" file we loaded earlier. Afterwards, I will alculate the confidence interval and then transform it from the interval relative to the mean to the absolute values representing the upper and lower boundaries of the confidence interval. Here I use a confidence interval of 95%. We first transform from wide to long format using the `pivot_longer()` function from the `{tidyr}` package. I merge the data frame containing the times to the long data frame with the mean ERP so that we have a column with numerical time points. Then we calculate the average amplitude per time point. Then using the `CI()` function from the `{Rmisc}` package, we calculate the upper and lower bounds of the confidence interval and add each as a separate column in the data frame.
```{r}
#| label: long-format
-
-ERP_plotdata <- MeanERPs |>
- pivot_longer(-c(ID,Condition), names_to = "Time", values_to = "Amplitude") |>
- mutate(Time = as.numeric(Time)) |>
- group_by(Condition,Time) |>
- summarise(Mean_Amplitude = mean(Amplitude),
- CIlower = Rmisc::CI(Amplitude, ci = 0.95)["lower"],
- CIupper = Rmisc::CI(Amplitude, ci = 0.95)["upper"])
+#| warning: false
+
+times <- times |>
+ pivot_longer(
+ cols = everything(),
+ names_to = "index", values_to = "time"
+ ) |>
+ mutate(timepoint = str_glue("v{row_number() + 3}")) |>
+ select(-index)
+
+erp_plotdata <- mean_erp |>
+ pivot_longer(
+ cols = -c(id, condition),
+ names_to = "timepoint", values_to = "amplitude"
+ ) |>
+ inner_join(times, by = "timepoint") |>
+ group_by(condition, time) |>
+ summarise(
+ mean_amplitude = mean(amplitude),
+ ci_lower = Rmisc::CI(amplitude, ci = 0.95)["lower"],
+ ci_upper = Rmisc::CI(amplitude, ci = 0.95)["upper"]
+ )
```
## Preparing to plot
+
Before we can start plotting, I just wanted to share one piece of code I found on StackOverflow. The question there was to move the x-axis and y-axis line towards 0, rather than the edge of the plot. You can find the question (and answers) [here](https://stackoverflow.com/questions/39071002/moving-x-or-y-axis-together-with-tick-labels-to-the-middle-of-a-single-ggplot-n){target="_blank"}. I combined two answers into a function that moves both the y- and the x-axis to 0. It is my personal preference to have a line indicating 0. This makes the plots easier to read and looks prettier too, but of course this is subjective. Alternatively we could also add a `geom_hline()` and `geom_vline()`, both with intercept at 0, and turn the axes off (as default in `theme_norment()`. This will still give you the lines at x=0 and y=0 but will keep the axis labels at 0.
I personally prefer to have a plot that is as clean as possible, to really put focus on the ERP curve. So I’d typically turn off the grid lines. I also remove one of the 0-ticks to avoid any awkward overlay with the axes, especially since the 0 is also indicated by the axis line already.
-I take the colors from our own `{normentR}` package. I ask for two colors from the "logo" palette.
+I take the colors from our own `{normentR}` package. I ask for two colors from the "logo" palette.
After running the chunk below, we have a beautiful ERP with a nice confidence interval. I hope this was helpful and informative. Good luck!
@@ -149,22 +177,29 @@ After running the chunk below, we have a beautiful ERP with a nice confidence in
colors <- norment_pal(palette = "logo")(2)
-ERPplot <- ggplot(ERP_plotdata, aes(x = Time, y = Mean_Amplitude,
- colour = Condition, group = Condition)) +
- geom_ribbon(aes(ymin = CIlower, ymax = CIupper, fill = Condition),
- alpha = 0.1, linetype = 0) +
- geom_line(size = 0.75) +
- scale_color_manual(values = colors) +
- scale_fill_manual(values = colors) +
- scale_x_continuous(breaks = c(seq(-2000,2000,500))) +
- scale_y_continuous(breaks = c(seq(-12,-1,2), seq(2,12,2))) +
+erp_plot <- ggplot(erp_plotdata, aes(
+ x = time, y = mean_amplitude,
+ colour = condition, group = condition
+)) +
+ geom_ribbon(aes(ymin = ci_lower, ymax = ci_upper, fill = condition),
+ alpha = 0.1, linetype = 0
+ ) +
+ geom_line(linewidth = 0.75) +
+ scale_color_manual(values = colors) +
+ scale_fill_manual(values = colors) +
+ scale_x_continuous(breaks = c(seq(-2000, 2000, 500))) +
+ scale_y_continuous(breaks = c(seq(-12, -1, 2), seq(2, 12, 2))) +
coord_cartesian() +
- labs(x = "Time (ms)",
- y = "Amplitude (µV)") +
+ labs(
+ x = "Time (ms)",
+ y = "Amplitude (µV)"
+ ) +
theme_norment(ticks = TRUE, grid = FALSE) +
theme(
- legend.position = c(0.9,0.1),
+ legend.position = c(0.9, 0.1),
axis.text.x = element_text(vjust = -0.1)
)
-shift_axes(ERPplot, x = 0, y = 0)
+shift_axes(erp_plot, x = 0, y = 0)
```
+
+**EDIT (2023-10-30)**: In the process of making some general updates to this site, I also revisited some of the code here. I improved the standard somewhat from when I first wrote this post in 2019 and brought it up to the code standards of 2023. The old version is of course available on GitHub.
diff --git a/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png b/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png
index 8a4531e..adefa09 100644
Binary files a/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png and b/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.markdown_strict_files/figure-markdown_strict/print-plot-1.png differ
diff --git a/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.md b/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.md
index 5cf53be..b0f5c0c 100644
--- a/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.md
+++ b/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.md
@@ -14,25 +14,29 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
+## Introduction
-Whenever I show my colleagues in the genetics group my results, the first things they say are "*can you show me the Manhattan plots?*" and "*can you show me the QQ plots?*". I covered how to make Manhattan plots in ggplot before (click [here](https://danielroelfs.com/blog/how-i-create-manhattan-plots-using-ggplot/) for a link. But now I want to go through how I make QQ plots. I'm aware that there's a number of packages available that offer this funcionality, but I feel they're for the most part a bit limiting compared to making the plot yourself using the `{ggplot2}` package. Another advantage I found of creating QQ plots myself, is that I got a better understanding of how GWAS summary statistics are projected on the QQ plot, and thus I got a better understanding of QQ plots. For this process, I'll use the `{tidyverse}` package (which includes `{ggplot2}`) for all operations, and the `{normentR}` package to simulate some summary statistics and get some of my preferred color palettes. The code to calculate the confidence interval is based on code from Kamil Slowikowski (click [here](https://gist.github.com/slowkow/9041570) to go to the Gist).
+Whenever I show my colleagues in the genetics group my results, the first things they say are "*can you show me the Manhattan plots?*" and "*can you show me the QQ plots?*". I covered how to make Manhattan plots in ggplot before (click [here](https://danielroelfs.com/blog/how-i-create-manhattan-plots-using-ggplot/) for a link. But now I want to go through how I make QQ plots. I'm aware that there's a number of packages available that offer this funcionality, but I feel they're for the most part a bit limiting compared to making the plot yourself using the `{ggplot2}` package. Another advantage I found of creating QQ plots myself, is that I got a better understanding of how GWAS summary statistics are projected on the QQ plot, and thus I got a better understanding of QQ plots. For this process, I'll use the `{tidyverse}` package (which includes `{ggplot2}`) for all operations, the `{ggtext}` package for some fancy plot labels, and the `{normentR}` package to simulate some summary statistics and get some of my preferred color palettes. The code to calculate the confidence interval is based on code from Kamil Slowikowski (click [here](https://gist.github.com/slowkow/9041570) to go to the Gist).
``` r
library(tidyverse)
+library(ggtext)
library(normentR)
```
-### Import data into R
+## Import data into R
First we'll simulate some summary statistics data. We can do this using the `simulateGWAS()` function in the `{normentR}` package for now. If you have summary statistics ready, you can load it in and use that instead.
``` r
set.seed(1994)
-sumstats.data <- simulateGWAS(nSNPs = 1e6, nSigCols = 1)
+sumstats_data <- simulateGWAS(nSNPs = 1e6, nSigCols = 1) |>
+ janitor::clean_names()
```
GENERATING SIMULATED GWAS DATASET
@@ -46,26 +50,34 @@ sumstats.data <- simulateGWAS(nSNPs = 1e6, nSigCols = 1)
8. Adding significant column in chromosome 8
DONE!
-Now we have a data frame called `sumstats.data` that contains a simulated GWAS summary statistic dataset. Note that I only generated a small number of SNPs. The QQ plot can take quite a while to generate if there's a lot of SNPs in the file. QQ plots require only the p-values, but we'll keep the entire data frame because you might need this data frame at some point later on.
+Now we have a data frame called `sumstats_data` that contains a simulated GWAS summary statistic dataset. Note that I only generated a small number of SNPs. The QQ plot can take quite a while to generate if there's a lot of SNPs in the file. QQ plots require only the p-values, but we'll keep the entire data frame because you might need this data frame at some point later on.
-### Preparing the data
+## Preparing the data
-First I'll specify two variables, just to make the code later somehwat cleaner. I'll want to plot an area indicating the confidence interval, so we specify the confidence interval (e.g. 95%) and the number of SNPs (which is just the length of your `sumstats.data` data frame)
+First I'll specify two variables, just to make the code later somehwat cleaner. I'll want to plot an area indicating the confidence interval, so we specify the confidence interval (e.g. 95%) and the number of SNPs (which is just the length of your `sumstats_data` data frame)
``` r
ci <- 0.95
-nSNPs <- nrow(sumstats.data)
+n_snps <- nrow(sumstats_data)
```
Next, we'll create a data frame that has all the data we need for the plot. We'll call that data frame `plotdata`. We initiate a data frame with four columns. The first column is the observed p-values, sorted in decreasing order, and then -log10 transformed. So then the SNPs with the lowest p-values will have the highest value. These SNPs will end up on the right side of the figure later. Based on this sorted vector, we can also generate the expected vector of log transformed p-values. We could do this manually, but I much prefer to use one of the (somewhat obscure but very useful) base functions in R called `ppoints()`. This generates the sequence of probabilities based on the input vector. In this case, we'll input just the number of SNPs.
Since we also want to plot the confidence interval, we'll have to calculate the upper and lower limits of the confidence interval at each point. For this we'll use another base function called `qbeta()`. This generates the `$\beta$` distribution for a given probabily value or range of values. For the lower half of the confidence interval, we'll take 1 (i.e. the null line) minus the confidence interval (`0.95`), and since this is only half of the interval, we'll divide that value by 2. We'll do the same for the upper half of the confidence interval, except not it's 1 plus the confidence interval. For both the upper and lower interval, we'll supply a vector from 1 to the number of SNPs in your data frame and then also the reverse. These two vectors will be the parameters of the `$\beta$` distribution. The output from all the functions below are the same length as the number of SNPs in your original data frame.
``` r
-plotdata <- data.frame(
- observed = -log10(sort(sumstats.data$P)),
- expected = -log10(ppoints(nSNPs)),
- clower = -log10(qbeta(p = (1 - ci) / 2, shape1 = seq(nSNPs), shape2 = rev(seq(nSNPs)))),
- cupper = -log10(qbeta(p = (1 + ci) / 2, shape1 = seq(nSNPs), shape2 = rev(seq(nSNPs))))
+plotdata <- tibble(
+ observed = -log10(sort(sumstats_data$p)),
+ expected = -log10(ppoints(n_snps)),
+ clower = -log10(qbeta(
+ p = (1 - ci) / 2,
+ shape1 = seq(n_snps),
+ shape2 = rev(seq(n_snps))
+ )),
+ cupper = -log10(qbeta(
+ p = (1 + ci) / 2,
+ shape1 = seq(n_snps),
+ shape2 = rev(seq(n_snps))
+ ))
)
```
@@ -81,42 +93,53 @@ plotdata_sub <- plotdata |>
plotdata_sup <- plotdata |>
filter(expected > 2)
-plotdata_small <- rbind(plotdata_sub, plotdata_sup)
+plotdata_small <- bind_rows(plotdata_sub, plotdata_sup)
```
Now we have a much smaller data frame, which should make plotting a lot faster!
-### Plotting the data
+## Plotting the data
Let's make a plot! We want the expected values on the x-axis, and the observed values on the y-axis. Then I'll make a `geom_ribbon()` layer with the upper and lower bounds of the confidence interval. Now, there's a few options. Some people prefer to see individual points (with `geom_point()`), but if you have a million SNPs, I don't think this always makes much sense. You can also use `geom_line()`, but I especially prefer `geom_step()`. This function creates a line between the dots in a stepwise manner, so strictly speaking there are no diagonal lines (but with many points in a region, it may look like a diagonal line). There's two options for the direction of the `geom_step()` function, to go from a point to the next first in vertical direction and then horizontal direction is `"vh"`, the other way around is denoted by `"hv"`. What is most suitable for your plot depends on what you want to look at. I'd recommend to be conservative, so if you're trying to assess inflation, go for `"vh"`, which will visually bias the curve upwards. If you're looking only at the quality of genetic signal in your GWAS, then go for `"hv"`, since that will visually bias the curve to be closer to the null line. If you're not sure, then just go for `geom_line()`.
When there is no signal in your GWAS, the expected and observed p-values should overlap perfectly. In that case there'll be a correlation of exactly 1. This is our reference value. In order to indicate this null-line, we can add a line with an intersect at 0 and a slope of 1 with the `geom_abline()` function. This `geom_abline()` will plot a line that exceeds the observed values. I prefer to use a `geom_segment()` so that I can specify the range of the line. I select the largest expected x- and y-value and plot a line from (0,0) to that point, which will perfectly correspond to a line with a slope of 1. Your line with observed p-values should never go below this null line. If it does, it means that the p-values that you measured are higher than could reasonably be expected under a null distrbution.
-We'll also add some labels (with the `expression()` and `paste()` functions). You may just copy paste this. I'll add my preferred theme (`theme_norment()`) and I added an empty `theme()` layer. I haven't added anything there yet, but perhaps if there's some unwanted behavior in the theme, you can fix it there.
+We'll also add some labels written in Markdown (that will be parsed with the `element_markdown()` function from the `{ggtext}` package. I'll add my preferred theme (`theme_norment()`) which looks a lot like the `theme_minimal()`.
``` r
-qqplot <- ggplot(plotdata_small, aes(x = expected, y = observed)) +
- geom_ribbon(aes(ymax = cupper, ymin = clower), fill = "grey30", alpha = 0.5) +
- geom_step(color = norment_colors[["purple"]], size = 1.1, direction = "vh") +
- geom_segment(data = . %>% filter(expected == max(expected)),
- aes(x = 0, xend = expected, y = 0, yend = expected),
- size = 1.25, alpha = 0.5, color = "grey30", lineend = "round") +
- labs(x = expression(paste("Expected -log"[10],"(", plain(P),")")),
- y = expression(paste("Observed -log"[10],"(", plain(P),")"))) +
+qqplot <- plotdata_small |>
+ ggplot(aes(x = expected, y = observed)) +
+ geom_ribbon(aes(ymax = cupper, ymin = clower),
+ fill = "grey30", alpha = 0.5
+ ) +
+ geom_step(
+ color = norment_colors[["purple"]],
+ linewidth = 1.1, direction = "vh"
+ ) +
+ geom_segment(
+ data = . %>% filter(expected == max(expected)),
+ aes(x = 0, xend = expected, y = 0, yend = expected),
+ linewidth = 1.25, alpha = 0.5,
+ color = "grey30", lineend = "round"
+ ) +
+ labs(
+ x = str_glue("Expected -log10(P)"),
+ y = str_glue("Observed -log10(P)")
+ ) +
theme_norment() +
- theme()
+ theme(
+ axis.title.x = element_markdown(),
+ axis.title.y = element_markdown()
+ )
```
- Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
- ℹ Please use `linewidth` instead.
-
I must issue a small warning now, since these GWAS files can be quite large, plotting all these values can take quite some time, so if you're working on an older MacBook Air (like I am) you may have to be a little patient. Let's see what the plot looks like.
``` r
print(qqplot)
```
-
+
Now we have our QQ plot. We see that our (simulated) GWAS dataset has a very nice signal! I'd be dissapointed if it didn't since I coded it to be this way. It is possible to annotate this plot further or to add multiple lines depending on thresholds (I'm thinking about conditional/conjunctional FDR thresholds for instance). Good luck!
diff --git a/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.qmd b/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.qmd
index 6e33364..adeaed6 100644
--- a/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.qmd
+++ b/content/blog/2020-how-i-make-qq-plots-using-ggplot/index.qmd
@@ -14,20 +14,23 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
-Whenever I show my colleagues in the genetics group my results, the first things they say are "_can you show me the Manhattan plots?_" and "_can you show me the QQ plots?_". I covered how to make Manhattan plots in ggplot before (click [here](https://danielroelfs.com/blog/how-i-create-manhattan-plots-using-ggplot/) for a link. But now I want to go through how I make QQ plots. I'm aware that there's a number of packages available that offer this funcionality, but I feel they're for the most part a bit limiting compared to making the plot yourself using the `{ggplot2}` package. Another advantage I found of creating QQ plots myself, is that I got a better understanding of how GWAS summary statistics are projected on the QQ plot, and thus I got a better understanding of QQ plots. For this process, I'll use the `{tidyverse}` package (which includes `{ggplot2}`) for all operations, and the `{normentR}` package to simulate some summary statistics and get some of my preferred color palettes. The code to calculate the confidence interval is based on code from Kamil Slowikowski (click [here](https://gist.github.com/slowkow/9041570) to go to the Gist).
+## Introduction
+Whenever I show my colleagues in the genetics group my results, the first things they say are "_can you show me the Manhattan plots?_" and "_can you show me the QQ plots?_". I covered how to make Manhattan plots in ggplot before (click [here](https://danielroelfs.com/blog/how-i-create-manhattan-plots-using-ggplot/) for a link. But now I want to go through how I make QQ plots. I'm aware that there's a number of packages available that offer this funcionality, but I feel they're for the most part a bit limiting compared to making the plot yourself using the `{ggplot2}` package. Another advantage I found of creating QQ plots myself, is that I got a better understanding of how GWAS summary statistics are projected on the QQ plot, and thus I got a better understanding of QQ plots. For this process, I'll use the `{tidyverse}` package (which includes `{ggplot2}`) for all operations, the `{ggtext}` package for some fancy plot labels, and the `{normentR}` package to simulate some summary statistics and get some of my preferred color palettes. The code to calculate the confidence interval is based on code from Kamil Slowikowski (click [here](https://gist.github.com/slowkow/9041570) to go to the Gist).
```{r}
#| label: pkgs
#| message: false
library(tidyverse)
+library(ggtext)
library(normentR)
```
-### Import data into R
+## Import data into R
First we'll simulate some summary statistics data. We can do this using the `simulateGWAS()` function in the `{normentR}` package for now. If you have summary statistics ready, you can load it in and use that instead.
```{r}
@@ -35,20 +38,21 @@ First we'll simulate some summary statistics data. We can do this using the `sim
set.seed(1994)
-sumstats.data <- simulateGWAS(nSNPs = 1e6, nSigCols = 1)
+sumstats_data <- simulateGWAS(nSNPs = 1e6, nSigCols = 1) |>
+ janitor::clean_names()
```
-Now we have a data frame called `sumstats.data` that contains a simulated GWAS summary statistic dataset. Note that I only generated a small number of SNPs. The QQ plot can take quite a while to generate if there's a lot of SNPs in the file. QQ plots require only the p-values, but we'll keep the entire data frame because you might need this data frame at some point later on.
+Now we have a data frame called `sumstats_data` that contains a simulated GWAS summary statistic dataset. Note that I only generated a small number of SNPs. The QQ plot can take quite a while to generate if there's a lot of SNPs in the file. QQ plots require only the p-values, but we'll keep the entire data frame because you might need this data frame at some point later on.
-### Preparing the data
+## Preparing the data
-First I'll specify two variables, just to make the code later somehwat cleaner. I'll want to plot an area indicating the confidence interval, so we specify the confidence interval (e.g. 95%) and the number of SNPs (which is just the length of your `sumstats.data` data frame)
+First I'll specify two variables, just to make the code later somehwat cleaner. I'll want to plot an area indicating the confidence interval, so we specify the confidence interval (e.g. 95%) and the number of SNPs (which is just the length of your `sumstats_data` data frame)
```{r}
#| label: set-params
ci <- 0.95
-nSNPs <- nrow(sumstats.data)
+n_snps <- nrow(sumstats_data)
```
Next, we'll create a data frame that has all the data we need for the plot. We'll call that data frame `plotdata`. We initiate a data frame with four columns. The first column is the observed p-values, sorted in decreasing order, and then -log~10~ transformed. So then the SNPs with the lowest p-values will have the highest value. These SNPs will end up on the right side of the figure later. Based on this sorted vector, we can also generate the expected vector of log transformed p-values. We could do this manually, but I much prefer to use one of the (somewhat obscure but very useful) base functions in R called `ppoints()`. This generates the sequence of probabilities based on the input vector. In this case, we'll input just the number of SNPs.
@@ -57,11 +61,19 @@ Since we also want to plot the confidence interval, we'll have to calculate the
```{r}
#| label: calculate-data
-plotdata <- data.frame(
- observed = -log10(sort(sumstats.data$P)),
- expected = -log10(ppoints(nSNPs)),
- clower = -log10(qbeta(p = (1 - ci) / 2, shape1 = seq(nSNPs), shape2 = rev(seq(nSNPs)))),
- cupper = -log10(qbeta(p = (1 + ci) / 2, shape1 = seq(nSNPs), shape2 = rev(seq(nSNPs))))
+plotdata <- tibble(
+ observed = -log10(sort(sumstats_data$p)),
+ expected = -log10(ppoints(n_snps)),
+ clower = -log10(qbeta(
+ p = (1 - ci) / 2,
+ shape1 = seq(n_snps),
+ shape2 = rev(seq(n_snps))
+ )),
+ cupper = -log10(qbeta(
+ p = (1 + ci) / 2,
+ shape1 = seq(n_snps),
+ shape2 = rev(seq(n_snps))
+ ))
)
```
@@ -79,40 +91,54 @@ plotdata_sub <- plotdata |>
plotdata_sup <- plotdata |>
filter(expected > 2)
-plotdata_small <- rbind(plotdata_sub, plotdata_sup)
+plotdata_small <- bind_rows(plotdata_sub, plotdata_sup)
```
Now we have a much smaller data frame, which should make plotting a lot faster!
-### Plotting the data
+## Plotting the data
Let's make a plot! We want the expected values on the x-axis, and the observed values on the y-axis. Then I'll make a `geom_ribbon()` layer with the upper and lower bounds of the confidence interval. Now, there's a few options. Some people prefer to see individual points (with `geom_point()`), but if you have a million SNPs, I don't think this always makes much sense. You can also use `geom_line()`, but I especially prefer `geom_step()`. This function creates a line between the dots in a stepwise manner, so strictly speaking there are no diagonal lines (but with many points in a region, it may look like a diagonal line). There's two options for the direction of the `geom_step()` function, to go from a point to the next first in vertical direction and then horizontal direction is `"vh"`, the other way around is denoted by `"hv"`. What is most suitable for your plot depends on what you want to look at. I'd recommend to be conservative, so if you're trying to assess inflation, go for `"vh"`, which will visually bias the curve upwards. If you're looking only at the quality of genetic signal in your GWAS, then go for `"hv"`, since that will visually bias the curve to be closer to the null line. If you're not sure, then just go for `geom_line()`.
When there is no signal in your GWAS, the expected and observed p-values should overlap perfectly. In that case there'll be a correlation of exactly 1. This is our reference value. In order to indicate this null-line, we can add a line with an intersect at 0 and a slope of 1 with the `geom_abline()` function. This `geom_abline()` will plot a line that exceeds the observed values. I prefer to use a `geom_segment()` so that I can specify the range of the line. I select the largest expected x- and y-value and plot a line from (0,0) to that point, which will perfectly correspond to a line with a slope of 1. Your line with observed p-values should never go below this null line. If it does, it means that the p-values that you measured are higher than could reasonably be expected under a null distrbution.
-We'll also add some labels (with the `expression()` and `paste()` functions). You may just copy paste this. I'll add my preferred theme (`theme_norment()`) and I added an empty `theme()` layer. I haven't added anything there yet, but perhaps if there's some unwanted behavior in the theme, you can fix it there.
+We'll also add some labels written in Markdown (that will be parsed with the `element_markdown()` function from the `{ggtext}` package. I'll add my preferred theme (`theme_norment()`) which looks a lot like the `theme_minimal()`.
```{r}
#| label: qqplot
-qqplot <- ggplot(plotdata_small, aes(x = expected, y = observed)) +
- geom_ribbon(aes(ymax = cupper, ymin = clower), fill = "grey30", alpha = 0.5) +
- geom_step(color = norment_colors[["purple"]], size = 1.1, direction = "vh") +
- geom_segment(data = . %>% filter(expected == max(expected)),
- aes(x = 0, xend = expected, y = 0, yend = expected),
- size = 1.25, alpha = 0.5, color = "grey30", lineend = "round") +
- labs(x = expression(paste("Expected -log"[10],"(", plain(P),")")),
- y = expression(paste("Observed -log"[10],"(", plain(P),")"))) +
+qqplot <- plotdata_small |>
+ ggplot(aes(x = expected, y = observed)) +
+ geom_ribbon(aes(ymax = cupper, ymin = clower),
+ fill = "grey30", alpha = 0.5
+ ) +
+ geom_step(
+ color = norment_colors[["purple"]],
+ linewidth = 1.1, direction = "vh"
+ ) +
+ geom_segment(
+ data = . %>% filter(expected == max(expected)),
+ aes(x = 0, xend = expected, y = 0, yend = expected),
+ linewidth = 1.25, alpha = 0.5,
+ color = "grey30", lineend = "round"
+ ) +
+ labs(
+ x = str_glue("Expected -log10(P)"),
+ y = str_glue("Observed -log10(P)")
+ ) +
theme_norment() +
- theme()
+ theme(
+ axis.title.x = element_markdown(),
+ axis.title.y = element_markdown()
+ )
```
I must issue a small warning now, since these GWAS files can be quite large, plotting all these values can take quite some time, so if you're working on an older MacBook Air (like I am) you may have to be a little patient. Let's see what the plot looks like.
```{r}
#| label: print-plot
-#| fig-height: 8
-#| fig-width: 8
+#| fig-height: 6
+#| fig-width: 6
print(qqplot)
```
diff --git a/content/blog/2020-plotting-star-destroyers-in-r/index.md b/content/blog/2020-plotting-star-destroyers-in-r/index.md
index 1588555..2d8b6ac 100644
--- a/content/blog/2020-plotting-star-destroyers-in-r/index.md
+++ b/content/blog/2020-plotting-star-destroyers-in-r/index.md
@@ -14,40 +14,42 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
+## Introduction
-Most people in my environment know R as the quintessential tool for statistical analysis and data visualization. There's plenty of tutorials and discussions online about how to go about either. But one important aspect that is noticeably lacking is a discussion about R's ability to simulate scenes from Star Wars. Today, we'll set this straight. At the same time we'll also explore how to incorporate a mathematical formula with a set of simple rules into R. This post is an R implementation of a formula published on the *On-line Encyclopedia of Integer Sequences* (OEIS, [sequence A117966](https://oeis.org/A117966)). Numberphile has a video from Brady Haran with Neil Sloane where they discuss the mathematics behind fun graphs, among which this one. It's a great video, you can check it out [**here**](https://youtu.be/o8c4uYnnNnc).
+Most people in my environment know R as the quintessential tool for statistical analysis and data visualization. There's plenty of tutorials and discussions online about how to go about either. But one important aspect that is noticeably lacking is a discussion about R's ability to simulate scenes from Star Wars. Today, we'll set this straight. At the same time we'll also explore how to incorporate a mathematical formula with a set of simple rules into R. This post is an R implementation of a formula published on the *On-line Encyclopedia of Integer Sequences* (OEIS, [sequence A117966](https://oeis.org/A117966)). Numberphile has a video from Brady Haran with Neil Sloane where they discuss the mathematics behind fun graphs, among which this one. It's a great video, you can check it out [here](https://youtu.be/o8c4uYnnNnc).
We'll use a formula called the *balanced ternary enumeration*. The game is to convert a decimal number to base 3, or the ternary. The best way to describe the ternary is to put it next to the binary. Binary (or base 2) is perhaps more widely understood. I don't actually know of any use of the ternary outside of these hypothetical mathematical problems. Octadecimal and hexadecimal are used sometimes. The latter is used for instance in defining colors in computers.
-### Let's start with counting
+## Let's start with counting
Let's start at the very basics. Like primary school basic. In the decimal system, we could from 1 to 9 and then add a digit and start from 1 again (\[1 2 3 ... 8 9 10 11 12 ... 20 21 ...\]) This system likely comes from the fact that humans have 10 fingers. (Interestingly, the Maya used a system with base 20, because they used their toes to count also, and there's a Native American tribe in California that uses base 8 because they use the space between fingers to count.) Computers use binary (base 2) because a pin or electrical signal can either be on or off. This means that there's two values available to denote a number, either 0 or 1. In this system each digit represents the double of the previous, starting from 1. So the first digit represents 1, the second 2, the third 4, the fourth 8 and so on. So the number 5 is made from adding 4 and 1 together, so the binary representation of the number 4 is 100, and 5 is 101. The number 6 is denoted as 110, and so on.
In a ternary system, this same principle applies as in the binary system, except digits now increase by a factor of 3. The first digit represents 1, the second 3, the third9 and so on. This also means that there's three possible values to denote a number, 0, 1, or 2. To illustrate how decimal numbers are represented in the binary and ternary system, look at the table below.
-| Decimal | Binary | Ternary |
+| decimal | binary | ternary |
|:-------:|:------:|:-------:|
-| 1 | 1 | 1 |
-| 2 | 10 | 2 |
-| 3 | 11 | 10 |
-| 4 | 100 | 11 |
-| 5 | 101 | 12 |
-| 6 | 110 | 20 |
-| 7 | 111 | 21 |
-| 8 | 1000 | 22 |
-| 9 | 1001 | 100 |
-| 10 | 1010 | 101 |
-| 11 | 1011 | 102 |
-| 12 | 1100 | 110 |
-| 13 | 1101 | 111 |
-| 14 | 1110 | 112 |
-| 15 | 1111 | 120 |
+| 1 | 00001 | 001 |
+| 2 | 00010 | 002 |
+| 3 | 00011 | 010 |
+| 4 | 00100 | 011 |
+| 5 | 00101 | 012 |
+| 6 | 00110 | 020 |
+| 7 | 00111 | 021 |
+| 8 | 01000 | 022 |
+| 9 | 01001 | 100 |
+| 10 | 01010 | 101 |
+| 11 | 01011 | 102 |
+| 12 | 01100 | 110 |
+| 13 | 01101 | 111 |
+| 14 | 01110 | 112 |
+| 15 | 01111 | 120 |
| 16 | 10000 | 121 |
| 17 | 10001 | 122 |
| 18 | 10010 | 200 |
@@ -55,14 +57,14 @@ In a ternary system, this same principle applies as in the binary system, except
| 20 | 10100 | 202 |
| 21 | 10101 | 210 |
-### Moving numbers between systems
+## Moving numbers between systems
-Unlike MATLAB (`dec2bin()`) or Python (`bin()`), R doesn't have a natural built-in function to convert decimal numbers to binary (unless you want to use the weird `intToBits()` function). So I wrote a function instead which continually appends the modulus while it loops through the digits of the numbers by dividing it in half continuously. The modulus is what is left after division of number x by number y. Let's take the number 13 as an example. In the first loop, the modulus of 13 when divided by 2 is 1. So that goes in the first position, representing value 1. The next digit in the binary system represents the value 2. So we divide our initial value by 2 (and round it to the lower integer it in case we get decimal points) and take the modulus again. So the modulus of 6 when divided by 2 is 0. So that's the second digit. The next loop will result in another 1 (`$x = 6; \lfloor x/2 \rfloor\ mod\ 2 = 1$`, `$\lfloor x \rfloor$` represents rounding `$x$` to the nearest lower integer, i.e. floor), and then in the final loop, we take half of 3 and take the modulus again (`$x = 3; \lfloor x/2 \rfloor\ mod\ 2 = 1$`). After this, when we floor 0.5, the loop cancels since from here on it will just produce an infinite amount of leading zero's. This function now gives us the value 1101, which corresponds to the table above. The code for this function looks like this:
+Unlike MATLAB (`dec2bin()`) or Python (`bin()`), R doesn't have a natural built-in function to convert decimal numbers to binary (unless you want to use the weird `intToBits()` function). So I wrote a function instead which continually appends the modulus while it loops through the digits of the numbers by dividing it in half continuously. The modulus is what is left after division of number x by number y. Let's take the number 13 as an example. In the first loop, the modulus of 13 when divided by 2 is 1. So that goes in the first position, representing value 1. The next digit in the binary system represents the value 2. So we divide our initial value by 2 (and round it to the lower integer it in case we get decimal points) and take the modulus again. So the modulus of 6 when divided by 2 is 0. So that's the second digit. The next loop will result in another 1 ($x = 6; \lfloor x/2 \rfloor\\mod 2 = 1$), $\lfloor x \rfloor$ represents rounding $x$ to the nearest lower integer, i.e. floor), and then in the final loop, we take half of 3 and take the modulus again ($x = 3; \lfloor x/2 \rfloor\mod 2 = 1$). After this, when we floor 0.5, the loop cancels since from here on it will just produce an infinite amount of leading zero's. This function now gives us the value 1101, which corresponds to the table above. The code for this function looks like this:
``` r
-ConvertToBinary <- function(x) {
+convert_to_binary <- function(x) {
out <- mod <- NULL
- while (x > 0 | is.null(mod)) {
+ while (x > 0 || is.null(mod)) {
mod <- x %% 2
out <- paste0(mod, out)
x <- floor(x / 2)
@@ -74,7 +76,7 @@ ConvertToBinary <- function(x) {
Let's run this function:
``` r
-ConvertToBinary(13)
+convert_to_binary(13)
```
[1] "1101"
@@ -82,12 +84,12 @@ ConvertToBinary(13)
Now in this function we've hard coded that the base is 2, but this code works for any base up to base 10 with just a simple rewrite of the code. If we go higher, e.g. base 11, we are going to have to start using letters to represent values, which I'm too lazy to implement right now. We can specify the base as an input variable.
``` r
-ConvertToBase <- function(x, base = NULL) {
+convert_to_base_n <- function(x, base = NULL) {
if (base > 10) {
stop("Function not defined for bases higher than 10")
}
out <- mod <- NULL
- while (x > 0 | is.null(mod)) {
+ while (x > 0 || is.null(mod)) {
mod <- x %% base
out <- paste0(mod, out)
x <- floor(x / base)
@@ -99,33 +101,35 @@ ConvertToBase <- function(x, base = NULL) {
These functions only accepts a single value, but to get the transformed value for a vector of integers we can use the `map()` function from `{purrr}`. `map()` as default outputs a list, but we can also ask for a character vector. We can then convert a number of values to binary like this:
``` r
-example_vector <- c(0:4,10,13,22,50,75,100)
-map_chr(example_vector, ConvertToBinary)
+example_vector <- c(seq(4), 10, 13, 22, 50, 75, 100)
+map_chr(example_vector, convert_to_binary)
```
- [1] "0" "1" "10" "11" "100" "1010" "1101"
- [8] "10110" "110010" "1001011" "1100100"
+ [1] "1" "10" "11" "100" "1010" "1101" "10110"
+ [8] "110010" "1001011" "1100100"
``` r
-map_chr(example_vector, base = 3, ConvertToBase)
+map_chr(example_vector, base = 3, convert_to_base_n)
```
- [1] "0" "1" "2" "10" "11" "101" "111" "211" "1212"
- [10] "2210" "10201"
+ [1] "1" "2" "10" "11" "101" "111" "211" "1212" "2210"
+ [10] "10201"
-### The rules of the game
+## The rules of the game
Okay, so here's the rules of the *balanced ternary enumeration* game We write all integers in base 3, and replace all digits that are 2 with -1 and then sum the outcome. Let's look at the first ten numbers in ternary:
``` r
-map_chr(seq(10), base = 3, ConvertToBase)
+map_chr(seq(10), base = 3, convert_to_base_n)
```
[1] "1" "2" "10" "11" "12" "20" "21" "22" "100" "101"
-So in this sequence, we would replace the second value (`2`) with `-1`, which makes -1. We would also replace the second digit of fifth value (`12`), which makes \[1,-1\], which, when we add these numbers up , makes 2. This because 1 in the first position denotes value 3, minus 1 in the second position (representing 1) makes 2 since `$(3*1) + (1*-1) = 2$`. The next value (`20`) has a 2 in the first position, replace this with -1 makes \[-1,0\]. The first position denotes 3, minus 0 in the second position, makes -3 since `$(3*-1) + (1*0) = -3$`. Applying the same rule to the sixth value gives `$(3*-1) + (1*1)$` which makes -2. The next value has two incidences of the number 2, replacing both with -1 gives `$(3*-1) + (1*-1)$` is equal to -4. Let's skip ahead a few numbers to decimal number 18, which in ternary becomes 200, where the first position represents the number 9. Replacing the 2 in this number gives `$(9*-1) + (3*0) + (1*0)$`, which makes -9. This process is the balanced ternary enumeration.
+So in this sequence, we would replace the second value (`2`) with `-1`, which makes -1. We would also replace the second digit of fifth value (`12`), which makes \[1,-1\], which, when we add these numbers up , makes 2. This because 1 in the first position denotes value 3, minus 1 in the second position (representing 1) makes 2 since $(3 * 1) + (1 * -1) = 2$. The next value (`20`) has a 2 in the first position, replace this with -1 makes \[-1,0\]. The first position denotes 3, minus 0 in the second position, makes -3 since $(3 * -1) + (1 * 0) = -3$.
-Just as show of proof, we can also apply the same formula to values that don't contain a 2, for instance decimal number 10, which becomes 101 in ternary. The formula for this becomes `$(9*1) + (3*0) + (1*1)$`, which makes again 10.
+Applying the same rule to the sixth value gives $(3 * -1) + (1 * 1)$ which makes -2. The next value has two incidences of the number 2, replacing both with -1 gives $(3 * -1) + (1 * -1)$ is equal to -4. Let's skip ahead a few numbers to decimal number 18, which in ternary becomes 200, where the first position represents the number 9. Replacing the 2 in this number gives $(9 * -1) + (3 * 0) + (1 * 0)$, which makes -9. This process is the balanced ternary enumeration.
+
+Just as show of proof, we can also apply the same formula to values that don't contain a 2, for instance decimal number 10, which becomes 101 in ternary. The formula for this becomes $(9 * 1) + (3 * 0) + (1 * 1)$, which makes again 10.
Let's put this sequence together:
@@ -133,9 +137,9 @@ Let's put this sequence together:
And that's balanced ternary enumeration.
-### Coding the formula
+## Coding the formula
-So obviously we are lazy, and don't want to do this process manually for thousands of values. that's why we're going to code it. For this step I translated some Python code to R syntax. The function I wrote to do one step of balanced ternary enumartion is shown below. The first value is always 0 (since it's a 0 in the first position, hence `$1*0 = 0$`). After this, we can incorporate the two steps (of converting into ternary and the enumeration) into one. The formula for this looks like this:
+So obviously we are lazy, and don't want to do this process manually for thousands of values. that's why we're going to code it. For this step I translated some Python code to R syntax. The function I wrote to do one step of balanced ternary enumartion is shown below. The first value is always 0 (since it's a 0 in the first position, hence $1 * 0 = 0$). After this, we can incorporate the two steps (of converting into ternary and the enumeration) into one. The formula for this looks like this:
$$
\begin{aligned}
@@ -146,38 +150,60 @@ a(3n + 2) &= 3 * a(n) - 1
\end{aligned}
$$
-The Python code for this function came from a website that collects mathematical functions and sequences and can be found [here](https://oeis.org/A117966). I've adapted it to work in R. Since 0 will always result in 0, this is hard coded in. Afterwards it is a nested function (I know, we all love it) where it iteratively calls itself until the input to the function is 0 and it stops. At that point we have out balanced ternary. This function only performs the calculation for one value. So getting a sequence means putting it in a `map()` function.
+{{< sidenote >}}
+The Python code for this function came from a website that collects mathematical functions and
+sequences and can be found [here](https://oeis.org/A117966)
+{{< /sidenote >}}
+
+In the function, since 0 will always result in 0, this is hard coded in. Afterwards it is a nested function (I know, we all love it) where it iteratively calls itself until the input to the function is 0 and it stops. At that point we have out balanced ternary. This function only performs the calculation for one value. So getting a sequence means putting it in a `map()` function.
``` r
-BTE <- function(x) {
+bte <- function(x) {
if (x == 0) {
return(0)
}
if (x %% 3 == 0) {
- return(3 * BTE(x / 3))
+ return(3 * bte(x / 3))
} else if (x %% 3 == 1) {
- return(3 * BTE((x - 1) / 3) + 1)
+ return(3 * bte((x - 1) / 3) + 1)
} else if (x %% 3 == 2) {
- return(3 * BTE((x - 2) / 3) - 1)
+ return(3 * bte((x - 2) / 3) - 1)
}
}
```
-Let's go through one iteration of this code. Let's say `x <- 3`. 3 modulo 3 is equal to 0, so we enter the first condition. The result of this is 3 multiplied by the outcome of the same function, except the input now is x divided by three, or 3/3, or 1, in our example. This becomes the new input for the function. 1 modulo 3 is equal to 1. So now we enter the second condition. Now the input to the `BTE()` function is 1 minus 1, divided by 3. This is 0, so we return 3 \* 0 + 1, which is equal to 3.
+
+
+
+Let's go through one iteration of this code. Let's say `x <- 3`. 3 modulo 3 is equal to 0, so we enter the first condition. The result of this is 3 multiplied by the outcome of the same function, except the input now is x divided by three, or 3/3, or 1, in our example. This becomes the new input for the function. 1 modulo 3 is equal to 1. So now we enter the second condition. Now the input to the `bte()` function is 1 minus 1, divided by 3. This is 0, so we return 3 \* 0 + 1, which is equal to 3.
If we plug the number 3 into the formula, we will get the same result:
``` r
-BTE(3)
+bte(3)
```
[1] 3
-Let's also look at a few other examples using the `map()` function again. Since the `BTE()` function outputs only integers, I use `map_dbl()`. Let's input a few examples:
+Let's also look at a few other examples using the `map()` function again. Since the `bte()` function outputs only integers, I use `map_dbl()`. Let's input a few examples:
``` r
-example_vector <- c(0,seq(10),500,1500,9999)
-map_dbl(example_vector, BTE)
+example_vector <- c(0, seq(10), 500, 1500, 9999)
+map_dbl(example_vector, bte)
```
[1] 0 1 -1 3 4 2 -3 -2 -4 9 10 -232 -696 9270
@@ -185,10 +211,10 @@ map_dbl(example_vector, BTE)
This corresponds to the values we created earlier, and the larger numbers make sense also. Okay, let's now create an entire sequence. We'll do 59.048 iterations (it'll become clear later why this specific number). We'll save the output in a variable called `starwars_seq` (forgotten yet that this thing started with Star Wars?).
``` r
-starwars_seq <- map_dbl(seq(59048), BTE)
+starwars_seq <- map_dbl(seq(59048), bte)
```
-### Plotting the Star Destroyers
+## Plotting the Star Destroyers
Now, when we plot the values as a scatter plot, it'll become maybe a bit clearer how this mathematical formula circles back to our Star Wars scene.
@@ -208,30 +234,42 @@ length(starwars_seq) == length(unique(starwars_seq))
[1] TRUE
-The first point of each "squadron" of star destroyers starts with a value that is the same in decimal system as it is in balanced ternary enumeration. Remember the length of the `starwars_seq` variable was 59 048? I chose that because it would start plotting a new squadron at x = 59 049. Let's confirm this:
+The first point of each "squadron" of star destroyers starts with a value that is the same in decimal system as it is in balanced ternary enumeration. Remember the length of the `starwars_seq` variable was 59 048? I chose that because it would start plotting a new squadron at `x = 59049`. Let's confirm this:
``` r
-BTE(59049)
+bte(59049)
```
[1] 59049
-There is a range of values where the input of the balanced ternary enumeration is equal to the outcome (or where the outcome is equal to the input divided by two times -1 (`$\frac{-x}{2}$`). There's a clear pattern to these numbers, but I've done enough maths for today, so I'll save it for another time.
+There is a range of values where the input of the balanced ternary enumeration is equal to the outcome (or where the outcome is equal to the input divided by two times -1 ($\frac{-x}{2}$). There's a clear pattern to these numbers, but I've done enough maths for today, so I'll save it for another time.
Anyway, the plot! It is cool and all, but let's make it look a bit more like Star Wars by changing some style elements. We'll also generate some stars. For fun's sake we'll also add a planet or moon.
``` r
set.seed(1983)
+
ggplot(data = NULL, aes(x = seq(starwars_seq), y = starwars_seq)) +
- geom_point(aes(x = sample(seq(-1e4,length(starwars_seq) + 1e4), 1e3),
- y = sample(seq(min(starwars_seq)-1e4,max(starwars_seq) + 1e4), 1e3),
- size = sample(runif(length(starwars_seq) + 1e4), 1e3)),
- shape = 18, color = "yellow") +
- geom_point(aes(x = sample(seq(starwars_seq), 1),
- y = sample(starwars_seq, 1)),
- shape = 19, size = 12, color = "darkslategray") +
+ geom_point(
+ aes(
+ x = sample(seq(-1e4, length(starwars_seq) + 1e4), 1e3),
+ y = sample(seq(
+ min(starwars_seq) - 1e4,
+ max(starwars_seq) + 1e4
+ ), 1e3),
+ size = sample(runif(length(starwars_seq) + 1e4), 1e3)
+ ),
+ shape = 18, color = "yellow"
+ ) +
+ geom_point(
+ aes(
+ x = sample(seq(starwars_seq), 1),
+ y = sample(starwars_seq, 1)
+ ),
+ shape = 19, size = 12, color = "darkslategray"
+ ) +
geom_point(size = 4, color = "grey90") +
- scale_size_continuous(range = c(1e-3,5e-1)) +
+ scale_size_continuous(range = c(1e-3, 5e-1)) +
theme_void() +
theme(
legend.position = "none",
@@ -249,7 +287,7 @@ We can create another plot (nothing related to Star Wars perhaps), that looks ni
``` r
ggplot(data = NULL, aes(x = seq(starwars_seq), y = starwars_seq)) +
- geom_line() +
+ geom_line() +
theme_minimal()
```
diff --git a/content/blog/2020-plotting-star-destroyers-in-r/index.qmd b/content/blog/2020-plotting-star-destroyers-in-r/index.qmd
index 4b749ac..d9e099b 100644
--- a/content/blog/2020-plotting-star-destroyers-in-r/index.qmd
+++ b/content/blog/2020-plotting-star-destroyers-in-r/index.qmd
@@ -14,14 +14,18 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
-Most people in my environment know R as the quintessential tool for statistical analysis and data visualization. There's plenty of tutorials and discussions online about how to go about either. But one important aspect that is noticeably lacking is a discussion about R's ability to simulate scenes from Star Wars. Today, we'll set this straight. At the same time we'll also explore how to incorporate a mathematical formula with a set of simple rules into R. This post is an R implementation of a formula published on the _On-line Encyclopedia of Integer Sequences_ (OEIS, [sequence A117966](https://oeis.org/A117966)). Numberphile has a video from Brady Haran with Neil Sloane where they discuss the mathematics behind fun graphs, among which this one. It's a great video, you can check it out [**here**](https://youtu.be/o8c4uYnnNnc).
+## Introduction
+
+Most people in my environment know R as the quintessential tool for statistical analysis and data visualization. There's plenty of tutorials and discussions online about how to go about either. But one important aspect that is noticeably lacking is a discussion about R's ability to simulate scenes from Star Wars. Today, we'll set this straight. At the same time we'll also explore how to incorporate a mathematical formula with a set of simple rules into R. This post is an R implementation of a formula published on the _On-line Encyclopedia of Integer Sequences_ (OEIS, [sequence A117966](https://oeis.org/A117966)). Numberphile has a video from Brady Haran with Neil Sloane where they discuss the mathematics behind fun graphs, among which this one. It's a great video, you can check it out [here](https://youtu.be/o8c4uYnnNnc).
We'll use a formula called the _balanced ternary enumeration_. The game is to convert a decimal number to base 3, or the ternary. The best way to describe the ternary is to put it next to the binary. Binary (or base 2) is perhaps more widely understood. I don't actually know of any use of the ternary outside of these hypothetical mathematical problems. Octadecimal and hexadecimal are used sometimes. The latter is used for instance in defining colors in computers.
-### Let's start with counting
+## Let's start with counting
+
Let's start at the very basics. Like primary school basic. In the decimal system, we could from 1 to 9 and then add a digit and start from 1 again ([1 2 3 ... 8 9 10 11 12 ... 20 21 ...]) This system likely comes from the fact that humans have 10 fingers. (Interestingly, the Maya used a system with base 20, because they used their toes to count also, and there's a Native American tribe in California that uses base 8 because they use the space between fingers to count.) Computers use binary (base 2) because a pin or electrical signal can either be on or off. This means that there's two values available to denote a number, either 0 or 1. In this system each digit represents the double of the previous, starting from 1. So the first digit represents 1, the second 2, the third 4, the fourth 8 and so on. So the number 5 is made from adding 4 and 1 together, so the binary representation of the number 4 is 100, and 5 is 101. The number 6 is denoted as 110, and so on.
In a ternary system, this same principle applies as in the binary system, except digits now increase by a factor of 3. The first digit represents 1, the second 3, the third9 and so on. This also means that there's three possible values to denote a number, 0, 1, or 2. To illustrate how decimal numbers are represented in the binary and ternary system, look at the table below.
@@ -31,17 +35,15 @@ In a ternary system, this same principle applies as in the binary system, except
#| message: false
library(tidyverse)
-
-reticulate::use_virtualenv("./.venv")
```
```{r}
#| label: define-funs
#| echo: false
-ConvertToBinary <- function(x) {
+convert_to_binary <- function(x) {
out <- mod <- NULL
- while (x > 0 | is.null(mod)) {
+ while (x > 0 || is.null(mod)) {
mod <- x %% 2
out <- paste0(mod, out)
x <- floor(x / 2)
@@ -49,12 +51,12 @@ ConvertToBinary <- function(x) {
return(out)
}
-ConvertToBase <- function(x, base = NULL) {
+convert_to_base_n <- function(x, base = NULL) {
if (base > 10) {
stop("Function not defined for bases higher than 10")
}
out <- mod <- NULL
- while (x > 0 | is.null(mod)) {
+ while (x > 0 || is.null(mod)) {
mod <- x %% base
out <- paste0(mod, out)
x <- floor(x / base)
@@ -69,27 +71,32 @@ ConvertToBase <- function(x, base = NULL) {
#| warning: false
illust_table <- tibble(
- Decimal = seq(1:21),
- Binary = map_chr(.x = Decimal, .f = ConvertToBinary),
- Ternary = map_chr(.x = Decimal, base = 3, .f = ConvertToBase)
+ decimal = seq(21),
+ binary = map_chr(.x = decimal, .f = convert_to_binary),
+ ternary = map_chr(.x = decimal, base = 3, .f = convert_to_base_n)
)
-knitr::kable(illust_table,
- align = "ccc",
- latex_header_includes = c("\\renewcommand{\\arraystretch}{1}")) |>
+illust_table |>
+ mutate(
+ binary = str_pad(binary, width = 5, side = "left", pad = "0"),
+ ternary = str_pad(ternary, width = 3, side = "left", pad = "0")
+ ) |>
+ knitr::kable(
+ align = "ccc"
+ ) |>
kableExtra::kable_styling(position = "center")
```
-### Moving numbers between systems
+## Moving numbers between systems
-Unlike MATLAB (`dec2bin()`) or Python (`bin()`), R doesn't have a natural built-in function to convert decimal numbers to binary (unless you want to use the weird `intToBits()` function). So I wrote a function instead which continually appends the modulus while it loops through the digits of the numbers by dividing it in half continuously. The modulus is what is left after division of number x by number y. Let's take the number 13 as an example. In the first loop, the modulus of 13 when divided by 2 is 1. So that goes in the first position, representing value 1. The next digit in the binary system represents the value 2. So we divide our initial value by 2 (and round it to the lower integer it in case we get decimal points) and take the modulus again. So the modulus of 6 when divided by 2 is 0. So that's the second digit. The next loop will result in another 1 (`$x = 6; \lfloor x/2 \rfloor\ mod\ 2 = 1$`, `$\lfloor x \rfloor$` represents rounding `$x$` to the nearest lower integer, i.e. floor), and then in the final loop, we take half of 3 and take the modulus again (`$x = 3; \lfloor x/2 \rfloor\ mod\ 2 = 1$`). After this, when we floor 0.5, the loop cancels since from here on it will just produce an infinite amount of leading zero's. This function now gives us the value 1101, which corresponds to the table above. The code for this function looks like this:
+Unlike MATLAB (`dec2bin()`) or Python (`bin()`), R doesn't have a natural built-in function to convert decimal numbers to binary (unless you want to use the weird `intToBits()` function). So I wrote a function instead which continually appends the modulus while it loops through the digits of the numbers by dividing it in half continuously. The modulus is what is left after division of number x by number y. Let's take the number 13 as an example. In the first loop, the modulus of 13 when divided by 2 is 1. So that goes in the first position, representing value 1. The next digit in the binary system represents the value 2. So we divide our initial value by 2 (and round it to the lower integer it in case we get decimal points) and take the modulus again. So the modulus of 6 when divided by 2 is 0. So that's the second digit. The next loop will result in another 1 ($x = 6; \lfloor x/2 \rfloor\\mod 2 = 1$), $\lfloor x \rfloor$ represents rounding $x$ to the nearest lower integer, i.e. floor), and then in the final loop, we take half of 3 and take the modulus again ($x = 3; \lfloor x/2 \rfloor\mod 2 = 1$). After this, when we floor 0.5, the loop cancels since from here on it will just produce an infinite amount of leading zero's. This function now gives us the value 1101, which corresponds to the table above. The code for this function looks like this:
```{r}
#| label: binary-func
-ConvertToBinary <- function(x) {
+convert_to_binary <- function(x) {
out <- mod <- NULL
- while (x > 0 | is.null(mod)) {
+ while (x > 0 || is.null(mod)) {
mod <- x %% 2
out <- paste0(mod, out)
x <- floor(x / 2)
@@ -103,7 +110,7 @@ Let's run this function:
```{r}
#| label: bin-13
-ConvertToBinary(13)
+convert_to_binary(13)
```
Now in this function we've hard coded that the base is 2, but this code works for any base up to base 10 with just a simple rewrite of the code. If we go higher, e.g. base 11, we are going to have to start using letters to represent values, which I'm too lazy to implement right now. We can specify the base as an input variable.
@@ -111,12 +118,12 @@ Now in this function we've hard coded that the base is 2, but this code works fo
```{r}
#| label: anybase-func
-ConvertToBase <- function(x, base = NULL) {
+convert_to_base_n <- function(x, base = NULL) {
if (base > 10) {
stop("Function not defined for bases higher than 10")
}
out <- mod <- NULL
- while (x > 0 | is.null(mod)) {
+ while (x > 0 || is.null(mod)) {
mod <- x %% base
out <- paste0(mod, out)
x <- floor(x / base)
@@ -130,24 +137,26 @@ These functions only accepts a single value, but to get the transformed value fo
```{r}
#| label: map-example
-example_vector <- c(0:4,10,13,22,50,75,100)
-map_chr(example_vector, ConvertToBinary)
-map_chr(example_vector, base = 3, ConvertToBase)
+example_vector <- c(seq(4), 10, 13, 22, 50, 75, 100)
+map_chr(example_vector, convert_to_binary)
+map_chr(example_vector, base = 3, convert_to_base_n)
```
-### The rules of the game
+## The rules of the game
Okay, so here's the rules of the _balanced ternary enumeration_ game We write all integers in base 3, and replace all digits that are 2 with -1 and then sum the outcome. Let's look at the first ten numbers in ternary:
```{r}
#| label: bte-ex
-map_chr(seq(10), base = 3, ConvertToBase)
+map_chr(seq(10), base = 3, convert_to_base_n)
```
-So in this sequence, we would replace the second value (`2`) with `-1`, which makes -1. We would also replace the second digit of fifth value (`12`), which makes [1,-1], which, when we add these numbers up , makes 2. This because 1 in the first position denotes value 3, minus 1 in the second position (representing 1) makes 2 since `$(3*1) + (1*-1) = 2$`. The next value (`20`) has a 2 in the first position, replace this with -1 makes [-1,0]. The first position denotes 3, minus 0 in the second position, makes -3 since `$(3*-1) + (1*0) = -3$`. Applying the same rule to the sixth value gives `$(3*-1) + (1*1)$` which makes -2. The next value has two incidences of the number 2, replacing both with -1 gives `$(3*-1) + (1*-1)$` is equal to -4. Let's skip ahead a few numbers to decimal number 18, which in ternary becomes 200, where the first position represents the number 9. Replacing the 2 in this number gives `$(9*-1) + (3*0) + (1*0)$`, which makes -9. This process is the balanced ternary enumeration.
+So in this sequence, we would replace the second value (`2`) with `-1`, which makes -1. We would also replace the second digit of fifth value (`12`), which makes [1,-1], which, when we add these numbers up , makes 2. This because 1 in the first position denotes value 3, minus 1 in the second position (representing 1) makes 2 since $(3 * 1) + (1 * -1) = 2$. The next value (`20`) has a 2 in the first position, replace this with -1 makes [-1,0]. The first position denotes 3, minus 0 in the second position, makes -3 since $(3 * -1) + (1 * 0) = -3$.
+
+Applying the same rule to the sixth value gives $(3 * -1) + (1 * 1)$ which makes -2. The next value has two incidences of the number 2, replacing both with -1 gives $(3 * -1) + (1 * -1)$ is equal to -4. Let's skip ahead a few numbers to decimal number 18, which in ternary becomes 200, where the first position represents the number 9. Replacing the 2 in this number gives $(9 * -1) + (3 * 0) + (1 * 0)$, which makes -9. This process is the balanced ternary enumeration.
-Just as show of proof, we can also apply the same formula to values that don't contain a 2, for instance decimal number 10, which becomes 101 in ternary. The formula for this becomes `$(9*1) + (3*0) + (1*1)$`, which makes again 10.
+Just as show of proof, we can also apply the same formula to values that don't contain a 2, for instance decimal number 10, which becomes 101 in ternary. The formula for this becomes $(9 * 1) + (3 * 0) + (1 * 1)$, which makes again 10.
Let's put this sequence together:
@@ -155,9 +164,9 @@ Let's put this sequence together:
And that's balanced ternary enumeration.
-### Coding the formula
+## Coding the formula
-So obviously we are lazy, and don't want to do this process manually for thousands of values. that's why we're going to code it. For this step I translated some Python code to R syntax. The function I wrote to do one step of balanced ternary enumartion is shown below. The first value is always 0 (since it's a 0 in the first position, hence `$1*0 = 0$`). After this, we can incorporate the two steps (of converting into ternary and the enumeration) into one. The formula for this looks like this:
+So obviously we are lazy, and don't want to do this process manually for thousands of values. that's why we're going to code it. For this step I translated some Python code to R syntax. The function I wrote to do one step of balanced ternary enumartion is shown below. The first value is always 0 (since it's a 0 in the first position, hence $1 * 0 = 0$). After this, we can incorporate the two steps (of converting into ternary and the enumeration) into one. The formula for this looks like this:
$$
\begin{aligned}
@@ -168,57 +177,64 @@ a(3n + 2) &= 3 * a(n) - 1
\end{aligned}
$$
-The Python code for this function came from a website that collects mathematical functions and sequences and can be found [here](https://oeis.org/A117966). I've adapted it to work in R. Since 0 will always result in 0, this is hard coded in. Afterwards it is a nested function (I know, we all love it) where it iteratively calls itself until the input to the function is 0 and it stops. At that point we have out balanced ternary. This function only performs the calculation for one value. So getting a sequence means putting it in a `map()` function.
+{{{< sidenote >}}}
+The Python code for this function came from a website that collects mathematical functions and
+sequences and can be found [here](https://oeis.org/A117966)
+{{{< /sidenote >}}}
-```{python}
-#| label: python-bte
-#| echo: false
-
-def BTE(x):
- if x == 0:
- return 0
- if x % 3 == 0:
- return 3*BTE(x/3)
- elif x % 3 == 1:
- return 3*BTE((x - 1)/3) + 1
- else:
- return 3*BTE((x - 2)/3) - 1
-```
+In the function, since 0 will always result in 0, this is hard coded in. Afterwards it is a nested function (I know, we all love it) where it iteratively calls itself until the input to the function is 0 and it stops. At that point we have out balanced ternary. This function only performs the calculation for one value. So getting a sequence means putting it in a `map()` function.
```{r}
#| label: bte-func
-BTE <- function(x) {
+bte <- function(x) {
if (x == 0) {
return(0)
}
if (x %% 3 == 0) {
- return(3 * BTE(x / 3))
+ return(3 * bte(x / 3))
} else if (x %% 3 == 1) {
- return(3 * BTE((x - 1) / 3) + 1)
+ return(3 * bte((x - 1) / 3) + 1)
} else if (x %% 3 == 2) {
- return(3 * BTE((x - 2) / 3) - 1)
+ return(3 * bte((x - 2) / 3) - 1)
}
}
```
-Let's go through one iteration of this code. Let's say `x <- 3`. 3 modulo 3 is equal to 0, so we enter the first condition. The result of this is 3 multiplied by the outcome of the same function, except the input now is x divided by three, or 3/3, or 1, in our example. This becomes the new input for the function. 1 modulo 3 is equal to 1. So now we enter the second condition. Now the input to the `BTE()` function is 1 minus 1, divided by 3. This is 0, so we return 3 * 0 + 1, which is equal to 3.
+```{python}
+#| label: python-bte
+#| code-fold: true
+#| code-summary: "Click here to see the function in Python"
+#| eval: false
+
+def bte(x):
+ if x == 0:
+ return 0
+ if x % 3 == 0:
+ return 3 * bte(x / 3)
+ elif x % 3 == 1:
+ return 3 * bte((x - 1) / 3) + 1
+ else:
+ return 3 * bte((x - 2) / 3) - 1
+```
+
+Let's go through one iteration of this code. Let's say `x <- 3`. 3 modulo 3 is equal to 0, so we enter the first condition. The result of this is 3 multiplied by the outcome of the same function, except the input now is x divided by three, or 3/3, or 1, in our example. This becomes the new input for the function. 1 modulo 3 is equal to 1. So now we enter the second condition. Now the input to the `bte()` function is 1 minus 1, divided by 3. This is 0, so we return 3 * 0 + 1, which is equal to 3.
If we plug the number 3 into the formula, we will get the same result:
```{r}
#| label: bte-3
-BTE(3)
+bte(3)
```
-Let's also look at a few other examples using the `map()` function again. Since the `BTE()` function outputs only integers, I use `map_dbl()`. Let's input a few examples:
+Let's also look at a few other examples using the `map()` function again. Since the `bte()` function outputs only integers, I use `map_dbl()`. Let's input a few examples:
```{r}
#| label: bte-vector
-example_vector <- c(0,seq(10),500,1500,9999)
-map_dbl(example_vector, BTE)
+example_vector <- c(0, seq(10), 500, 1500, 9999)
+map_dbl(example_vector, bte)
```
This corresponds to the values we created earlier, and the larger numbers make sense also. Okay, let's now create an entire sequence. We'll do 59.048 iterations (it'll become clear later why this specific number). We'll save the output in a variable called `starwars_seq` (forgotten yet that this thing started with Star Wars?).
@@ -226,10 +242,10 @@ This corresponds to the values we created earlier, and the larger numbers make s
```{r}
#| label: bte-starwars
-starwars_seq <- map_dbl(seq(59048), BTE)
+starwars_seq <- map_dbl(seq(59048), bte)
```
-### Plotting the Star Destroyers
+## Plotting the Star Destroyers
Now, when we plot the values as a scatter plot, it'll become maybe a bit clearer how this mathematical formula circles back to our Star Wars scene.
@@ -249,15 +265,15 @@ It's star destroyers in battle formation! How crazy is that!? It's such an inter
length(starwars_seq) == length(unique(starwars_seq))
```
-The first point of each "squadron" of star destroyers starts with a value that is the same in decimal system as it is in balanced ternary enumeration. Remember the length of the `starwars_seq` variable was 59 048? I chose that because it would start plotting a new squadron at x = 59 049. Let's confirm this:
+The first point of each "squadron" of star destroyers starts with a value that is the same in decimal system as it is in balanced ternary enumeration. Remember the length of the `starwars_seq` variable was 59 048? I chose that because it would start plotting a new squadron at `x = 59049`. Let's confirm this:
```{r}
#| label: bte-last
-BTE(59049)
+bte(59049)
```
-There is a range of values where the input of the balanced ternary enumeration is equal to the outcome (or where the outcome is equal to the input divided by two times -1 (`$\frac{-x}{2}$`). There's a clear pattern to these numbers, but I've done enough maths for today, so I'll save it for another time.
+There is a range of values where the input of the balanced ternary enumeration is equal to the outcome (or where the outcome is equal to the input divided by two times -1 ($\frac{-x}{2}$). There's a clear pattern to these numbers, but I've done enough maths for today, so I'll save it for another time.
Anyway, the plot! It is cool and all, but let's make it look a bit more like Star Wars by changing some style elements. We'll also generate some stars. For fun's sake we'll also add a planet or moon.
@@ -265,16 +281,28 @@ Anyway, the plot! It is cool and all, but let's make it look a bit more like Sta
#| label: plot-pretty
set.seed(1983)
+
ggplot(data = NULL, aes(x = seq(starwars_seq), y = starwars_seq)) +
- geom_point(aes(x = sample(seq(-1e4,length(starwars_seq) + 1e4), 1e3),
- y = sample(seq(min(starwars_seq)-1e4,max(starwars_seq) + 1e4), 1e3),
- size = sample(runif(length(starwars_seq) + 1e4), 1e3)),
- shape = 18, color = "yellow") +
- geom_point(aes(x = sample(seq(starwars_seq), 1),
- y = sample(starwars_seq, 1)),
- shape = 19, size = 12, color = "darkslategray") +
+ geom_point(
+ aes(
+ x = sample(seq(-1e4, length(starwars_seq) + 1e4), 1e3),
+ y = sample(seq(
+ min(starwars_seq) - 1e4,
+ max(starwars_seq) + 1e4
+ ), 1e3),
+ size = sample(runif(length(starwars_seq) + 1e4), 1e3)
+ ),
+ shape = 18, color = "yellow"
+ ) +
+ geom_point(
+ aes(
+ x = sample(seq(starwars_seq), 1),
+ y = sample(starwars_seq, 1)
+ ),
+ shape = 19, size = 12, color = "darkslategray"
+ ) +
geom_point(size = 4, color = "grey90") +
- scale_size_continuous(range = c(1e-3,5e-1)) +
+ scale_size_continuous(range = c(1e-3, 5e-1)) +
theme_void() +
theme(
legend.position = "none",
@@ -292,6 +320,6 @@ We can create another plot (nothing related to Star Wars perhaps), that looks ni
#| label: plot-castle
ggplot(data = NULL, aes(x = seq(starwars_seq), y = starwars_seq)) +
- geom_line() +
+ geom_line() +
theme_minimal()
```
diff --git a/content/blog/2020-running-an-ica-on-questionnaires/codebook.txt b/content/blog/2020-running-an-ica-on-questionnaires/data/codebook.txt
similarity index 100%
rename from content/blog/2020-running-an-ica-on-questionnaires/codebook.txt
rename to content/blog/2020-running-an-ica-on-questionnaires/data/codebook.txt
diff --git a/content/blog/2020-running-an-ica-on-questionnaires/codebook_clean.txt b/content/blog/2020-running-an-ica-on-questionnaires/data/codebook_clean.txt
similarity index 100%
rename from content/blog/2020-running-an-ica-on-questionnaires/codebook_clean.txt
rename to content/blog/2020-running-an-ica-on-questionnaires/data/codebook_clean.txt
diff --git a/content/blog/2020-running-an-ica-on-questionnaires/data.csv b/content/blog/2020-running-an-ica-on-questionnaires/data/data.csv
similarity index 100%
rename from content/blog/2020-running-an-ica-on-questionnaires/data.csv
rename to content/blog/2020-running-an-ica-on-questionnaires/data/data.csv
diff --git a/content/blog/2020-running-an-ica-on-questionnaires/index.markdown_strict_files/figure-markdown_strict/plot-wmatrix-nolabs-1.png b/content/blog/2020-running-an-ica-on-questionnaires/index.markdown_strict_files/figure-markdown_strict/plot-wmatrix-nolabs-1.png
index c3fc090..aecc4aa 100644
Binary files a/content/blog/2020-running-an-ica-on-questionnaires/index.markdown_strict_files/figure-markdown_strict/plot-wmatrix-nolabs-1.png and b/content/blog/2020-running-an-ica-on-questionnaires/index.markdown_strict_files/figure-markdown_strict/plot-wmatrix-nolabs-1.png differ
diff --git a/content/blog/2020-running-an-ica-on-questionnaires/index.md b/content/blog/2020-running-an-ica-on-questionnaires/index.md
index a36a7df..4ff2689 100644
--- a/content/blog/2020-running-an-ica-on-questionnaires/index.md
+++ b/content/blog/2020-running-an-ica-on-questionnaires/index.md
@@ -15,9 +15,11 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
+## Introduction
If there was a statistics magazine and it were to have ads, the ad for independent component analysis (commonly referred to as the ICA) might read something like this:
@@ -27,9 +29,13 @@ If there was a statistics magazine and it were to have ads, the ad for independe
Obviously, there is more to it than this, but I don't have the time to talk about the statistical properties of ICA. There's many people who can explain this a hell of a lot better than I could anyway. I'm going to assume you've done your homework and already know that ICA is the right strategy to answer your research question and you just want to know how to implement it in R. That's what this tutorial is for. We'll run both a PCA and an ICA and visualize the results.
-### Getting the data
+## Getting the data
-We'll use a dataset called the *Nerdy Personality Attributes Scale* from the [Open-Source Psychometrics Project](https://openpsychometrics.org/tests/OSRI/development/). The dataset can be downloaded from [Kaggle](https://www.kaggle.com/lucasgreenwell/nerdy-personality-attributes-scale-responses/version/1?select=data.csv). In short, it's a questionnaire on "nerdiness". It aims to measure attributes of ones personality that reflect the popular understanding of "nerdiness". It is a series of questions to which participants are supposed to rank themselves on a Likert scale. The questionnaire has a high reliability, but the questionnaire isn't immune to valid criticisms. Here, we'll use this dataset to see if we can identify subtypes of the concept of "nerdiness" in our dataset.
+{{< sidenote br="2em" >}}
+The dataset is available for download on [Kaggle](https://www.kaggle.com/lucasgreenwell/nerdy-personality-attributes-scale-responses/version/1?select=data.csv)
+{{< /sidenote >}}
+
+We'll use a dataset called the *Nerdy Personality Attributes Scale* from the [Open-Source Psychometrics Project](https://openpsychometrics.org/tests/OSRI/development/). In short, it's a questionnaire on "nerdiness". It aims to measure attributes of ones personality that reflect the popular understanding of "nerdiness". It is a series of questions to which participants are supposed to rank themselves on a Likert scale. The questionnaire has a high reliability, but the questionnaire isn't immune to valid criticisms. Here, we'll use this dataset to see if we can identify subtypes of the concept of "nerdiness" in our dataset.
The dataset in question consists of almost 20.000 individuals from 149 different countries. Is there any reliable way to ensure that the tests are filled in correctly? No, definitely not. Does that make it a unreliable dataset for scientific analysis? Probably. Both issues are perhaps slightly confounded by its sheer size, but the dataset serves our goal well, which is to run an ICA in R. We'll use the `{tidyverse}` package and the `{fastICA}` package.
@@ -41,24 +47,31 @@ library(fastICA)
There are two files we need, one with the actual data (we'll call this `loaddata`), and one with the list of questions (we'll call this `loadcodes`).
``` r
-loaddata <- read_delim("data.csv", delim = "\t") |>
- mutate(id = row_number())
-
-loadcodes <- read_delim("codebook_clean.txt", delim = "\t", col_names = FALSE) |>
- rename(qnum = X1,
- question = X2)
+loaddata <- read_delim("./data/data.csv", delim = "\t") |>
+ rowid_to_column(var = "id")
+
+loadcodes <- read_delim("./data/codebook_clean.txt",
+ delim = "\t", col_names = FALSE
+) |>
+ rename(
+ qnum = X1,
+ question = X2
+ )
```
After cleaning, we still have more than 250.000 individual records left. This is great! Now we're going to have to do some preprocessing before we run the ICA.
-### Preprocessing of the data
+## Preprocessing of the data
Next, we want to prune the data. We want to exclude questions that have a low degree of variance and we might want to remove or impute questions with a large number of `NA`s. Our first step is to get the data in a format that's easier to work with, in this case, the long format. We'll select all questions, and put the question number in a column called `question` and the values in a column called `score`.
``` r
questdata <- loaddata |>
select(starts_with("Q")) |>
- pivot_longer(cols = everything(), names_to = "question", values_to = "score")
+ pivot_longer(
+ cols = everything(),
+ names_to = "question", values_to = "score"
+ )
```
We'll first find if there's any unanswered questions. These are rows where `score` is `NA`.
@@ -79,7 +92,7 @@ The next step is to find if there are questions with insufficient variation in a
less15var <- questdata |>
group_by(question, score) |>
count() |>
- group_by(question) |>
+ group_by(question) |>
mutate(perc = n / sum(n)) |>
arrange(question, -perc) |>
slice(2) |>
@@ -92,28 +105,32 @@ print(less15var)
# Groups: question [0]
# ℹ 4 variables: question Click here to see the function in Python
+ +``` python +def bte(x): + if x == 0: + return 0 + if x % 3 == 0: + return 3 * bte(x / 3) + elif x % 3 == 1: + return 3 * bte((x - 1) / 3) + 1 + else: + return 3 * bte((x - 2) / 3) - 1 +``` + +
It can be a bit hard to see from the plot how many components have an eigenvalue larger than 1. But we can calulate it. The number of components with an eigenvalue larger than 1 will be the number of independent components we'll request from the ICA.
``` r
-nICs <- pca_stats |>
+n_ics <- pca_stats |>
filter(var > 1) |>
nrow()
-print(nICs)
+print(n_ics)
```
[1] 6
-### Run ICA
+## Run ICA
Now we're ready to run the ICA! We'll use the `fastICA()` function. The function has a bunch of inputs. We'll pick the parallel algorithm (as opposed to the "deflation" algorithm). In the parallel algorithm the components are extracted simultaneously, with the deflation algorithm they're calculated one at a time. The "fun" option defines the form of the entropy function. I'm not 100% sure what it does. Just set it to `"exp"` and move on. For the `"method"` option there are two options: `"R"` or `"C"`. In the first option, all analyses are run in R, in the second option, all code is run in C, which is slightly faster. I typically use the `"C"` option. The `maxit` option defines the maximum number of iterations to perform. The default is 200, but in complex datasets, it may take a larger number of iterations to converge. That's why I set it to 5000. This process may take a while. If you want to follow along with what the algorithm is doing, you can set the `verbose` option to `TRUE`.
``` r
set.seed(2020)
-ica_model <- fastICA(mat, n.comp = nICs, alg.typ = "parallel",
- fun = "exp", method = "C", maxit = 5000)
+
+ica_model <- fastICA(mat,
+ n.comp = n_ics, alg.typ = "parallel",
+ fun = "exp", method = "C", maxit = 5000
+)
```
-### Create Weight Matrix
+## Create Weight Matrix
So now we have run the ICA decomposition. The function provides a few outputs:
@@ -233,7 +257,7 @@ Then we can also have a quick look at hierarchical clustering. This is a process
``` r
weight_matrix <- data.frame(t(ica_model$A))
-names(weight_matrix) <- paste0("IC",seq(weight_matrix))
+names(weight_matrix) <- str_glue("IC{seq(weight_matrix)}")
dist_matrix <- dist(as.matrix(weight_matrix))
clust <- hclust(dist_matrix)
@@ -244,37 +268,64 @@ plot(clust)
What we can see from the dendrogram is that for instance question 16 (*"I gravitate towards introspection"*) and question 17 (*"I am more comfortable interacting online than in person"*) on the left are very similar. Question 3 (*"I like to play RPGs. (Ex. D&D)"*) is somewhat similar, but not as much as question 16 and 17. The same goes for question 1 and 4, question 11 and 19, and so on.
+{{< sidenote br="1.5em" >}}
+We'll also do some cleaning of the questions that will help us make the plot look nicer later
+{{< /sidenote >}}
+
``` r
codes <- loadcodes |>
- filter(str_detect(qnum, "Q"))
+ filter(str_detect(qnum, "Q")) |>
+ mutate(
+ question = str_remove_all(question, "\t"),
+ question = str_remove(question, "\\.$")
+ )
```
Next we'll plot the weight matrix. For that we first create a column with the question number, we'll then merge the matrix with the list of questions so we can plot the actual question asked instead of the question number. Next, we'll put the data frame in a long format. Finally, we'll also reorder the questions to match the order determined by the hierarchical clustering.
+{{< sidenote br="4em" >}}
+The `%>%` pipe is necessary here because the placeholder functions a bit differently from the R's native `|>` pipe
+{{< /sidenote >}}
+
``` r
weight_matrix_long <- weight_matrix |>
mutate(qnum = str_glue("Q{row_number()}")) |>
inner_join(codes, by = "qnum") |>
- pivot_longer(cols = starts_with("IC"), names_to = "IC", values_to = "loading") %>%
- mutate(question = as_factor(question),
- question = fct_relevel(question, unique(.$question)[clust$order]))
+ pivot_longer(
+ cols = starts_with("IC"),
+ names_to = "IC", values_to = "loading"
+ ) %>%
+ mutate(
+ question = fct_relevel(
+ question,
+ unique(.$question)[clust$order]
+ ),
+ )
```
So let's see what the ICA spit out. We'll make a plot where the questions are shown along the y-axis and where the x-axis shows their loading onto the different independent components. The orientation of the loading between the components does not have meaning, but within the components it can indicate that some questions have opposing effects. We'll reorder the x- and y-axis to order it based on the loading strength.
``` r
-ggplot(weight_matrix_long, aes(x = IC, y = question, fill = loading)) +
- geom_tile() +
- labs(x = NULL,
- y = NULL,
- fill = NULL) +
- scale_fill_gradient2(low = "#FF729F", mid = "black", high = "#7EE8FA", limits = c(-1, 1),
- guide = guide_colorbar(barwidth = 0.5, barheight = 15, ticks = FALSE)) +
- theme_minimal(base_size = 8) +
+weight_matrix_long |>
+ ggplot(aes(x = IC, y = question, fill = loading)) +
+ geom_tile() +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = NULL
+ ) +
+ scale_fill_gradient2(
+ low = "#FF729F", mid = "black", high = "#7EE8FA",
+ limits = c(-1, 1),
+ guide = guide_colorbar(
+ barwidth = 0.5,
+ barheight = 15, ticks = FALSE
+ )
+ ) +
+ theme_minimal(base_size = 10) +
theme(
legend.position = "right",
- panel.grid = element_blank(),
- axis.text.x = element_text(size = 6),
+ panel.grid = element_blank()
)
```
diff --git a/content/blog/2020-running-an-ica-on-questionnaires/index.qmd b/content/blog/2020-running-an-ica-on-questionnaires/index.qmd
index 66dbae1..d27ff51 100644
--- a/content/blog/2020-running-an-ica-on-questionnaires/index.qmd
+++ b/content/blog/2020-running-an-ica-on-questionnaires/index.qmd
@@ -15,9 +15,11 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-### Introduction
+## Introduction
If there was a statistics magazine and it were to have ads, the ad for independent component analysis (commonly referred to as the ICA) might read something like this:
@@ -27,9 +29,13 @@ If there was a statistics magazine and it were to have ads, the ad for independe
Obviously, there is more to it than this, but I don't have the time to talk about the statistical properties of ICA. There's many people who can explain this a hell of a lot better than I could anyway. I'm going to assume you've done your homework and already know that ICA is the right strategy to answer your research question and you just want to know how to implement it in R. That's what this tutorial is for. We'll run both a PCA and an ICA and visualize the results.
-### Getting the data
+## Getting the data
-We'll use a dataset called the _Nerdy Personality Attributes Scale_ from the [Open-Source Psychometrics Project](https://openpsychometrics.org/tests/OSRI/development/). The dataset can be downloaded from [Kaggle](https://www.kaggle.com/lucasgreenwell/nerdy-personality-attributes-scale-responses/version/1?select=data.csv). In short, it's a questionnaire on "nerdiness". It aims to measure attributes of ones personality that reflect the popular understanding of "nerdiness". It is a series of questions to which participants are supposed to rank themselves on a Likert scale. The questionnaire has a high reliability, but the questionnaire isn't immune to valid criticisms. Here, we'll use this dataset to see if we can identify subtypes of the concept of "nerdiness" in our dataset.
+{{{< sidenote br="2em" >}}}
+The dataset is available for download on [Kaggle](https://www.kaggle.com/lucasgreenwell/nerdy-personality-attributes-scale-responses/version/1?select=data.csv)
+{{{< /sidenote >}}}
+
+We'll use a dataset called the _Nerdy Personality Attributes Scale_ from the [Open-Source Psychometrics Project](https://openpsychometrics.org/tests/OSRI/development/). In short, it's a questionnaire on "nerdiness". It aims to measure attributes of ones personality that reflect the popular understanding of "nerdiness". It is a series of questions to which participants are supposed to rank themselves on a Likert scale. The questionnaire has a high reliability, but the questionnaire isn't immune to valid criticisms. Here, we'll use this dataset to see if we can identify subtypes of the concept of "nerdiness" in our dataset.
The dataset in question consists of almost 20.000 individuals from 149 different countries. Is there any reliable way to ensure that the tests are filled in correctly? No, definitely not. Does that make it a unreliable dataset for scientific analysis? Probably. Both issues are perhaps slightly confounded by its sheer size, but the dataset serves our goal well, which is to run an ICA in R. We'll use the `{tidyverse}` package and the `{fastICA}` package.
@@ -48,17 +54,21 @@ There are two files we need, one with the actual data (we'll call this `loaddata
#| message: false
#| warning: false
-loaddata <- read_delim("data.csv", delim = "\t") |>
- mutate(id = row_number())
+loaddata <- read_delim("./data/data.csv", delim = "\t") |>
+ rowid_to_column(var = "id")
-loadcodes <- read_delim("codebook_clean.txt", delim = "\t", col_names = FALSE) |>
- rename(qnum = X1,
- question = X2)
+loadcodes <- read_delim("./data/codebook_clean.txt",
+ delim = "\t", col_names = FALSE
+) |>
+ rename(
+ qnum = X1,
+ question = X2
+ )
```
After cleaning, we still have more than 250.000 individual records left. This is great! Now we're going to have to do some preprocessing before we run the ICA.
-### Preprocessing of the data
+## Preprocessing of the data
Next, we want to prune the data. We want to exclude questions that have a low degree of variance and we might want to remove or impute questions with a large number of `NA`s. Our first step is to get the data in a format that's easier to work with, in this case, the long format. We'll select all questions, and put the question number in a column called `question` and the values in a column called `score`.
@@ -67,7 +77,10 @@ Next, we want to prune the data. We want to exclude questions that have a low de
questdata <- loaddata |>
select(starts_with("Q")) |>
- pivot_longer(cols = everything(), names_to = "question", values_to = "score")
+ pivot_longer(
+ cols = everything(),
+ names_to = "question", values_to = "score"
+ )
```
We'll first find if there's any unanswered questions. These are rows where `score` is `NA`.
@@ -90,7 +103,7 @@ The next step is to find if there are questions with insufficient variation in a
less15var <- questdata |>
group_by(question, score) |>
count() |>
- group_by(question) |>
+ group_by(question) |>
mutate(perc = n / sum(n)) |>
arrange(question, -perc) |>
slice(2) |>
@@ -99,37 +112,39 @@ less15var <- questdata |>
print(less15var)
```
-So no question has too little variance. If there was, I'd remove that question like so:
-
-```{r}
-#| label: remove-low-var
-
-data <- loaddata |>
- select(-less15var$question)
-```
+So no question has too little variance. If there were, I'd remove those questions from the analysis. Since no question has less than 15% variance, we won't drop any questions and use all of them in the analysis.
Next we want to normalize the data. Usually you'd do this to ensure that all answers on a questionnaire are in the same domain. Let's imagine a scenario where some questions are scored from 0 to 10, others are scored from 0 to 5, and a third is scored from 80 to 120. The ICA is then biased towards questions that have larger values, like the third question in the example above. That's why we want to normalize the data. The statistical term for this is z-score normalization. The defining property of z-scored transformed data is that the mean is 0 and the standard deviation is one. The z-score transformation is obtained by subtracting the mean from each individual value and then dividing by the standard deviation. This is implemented in R with the `scale()` function. We'll also check if it worked afterwards.
+{{{< sidenote >}}}
+In this case, the second line with the `select()` function doesn't remove anything, see paragraph above
+{{{< /sidenote >}}}
+
```{r}
#| label: normalize-data
-data <- data |>
- pivot_longer(starts_with("Q"), names_to = "qnum", values_to = "score") |>
+data <- loaddata |>
+ select(-less15var$question) |>
+ pivot_longer(starts_with("Q"),
+ names_to = "qnum", values_to = "score"
+ ) |>
group_by(qnum) |>
mutate(score_z = scale(score))
data |>
ungroup() |>
select(score_z) |>
- summarise(mean = mean(score_z),
- sd = sd(score_z),
- min = min(score_z),
- max = max(score_z))
+ summarise(
+ mean = mean(score_z),
+ sd = sd(score_z),
+ min = min(score_z),
+ max = max(score_z)
+ )
```
Great! Now we have a nice normalized dataset, without any missing values, and with questions that have a low degree of variance removed. All those preparations served to get us to a place where our clustering analyses are actually valid. Now it's time for the fun stuff!
-### Run PCA
+## Run PCA
There's two clustering approaches we'll use. One will actually help us do the other. The ICA algorithm has is unsupervised, but does require us to tell it how many components we want to get out of the algorithm. It's complicated to calculate the ideal number of components up front, but we can use some standards. I usually use a combination of [icasso](https://research.ics.aalto.fi/ica/icasso/) and PCA. We'll first do a principal component analysis (PCA). We can calculate the eigenvalue of each component in the PCA. PCA components are organized in decreasing order of variance explained. The threshold I use is an eigenvalue of 1. The number of PCA components with an eigenvalue larger than 1 is possibly a good number of components to give the ICA.
@@ -139,7 +154,10 @@ The PCA is implemented in the `prcomp()` function. This function doesn't accept
#| label: run-pca
mat <- data |>
- pivot_wider(names_from = "qnum", values_from = "score_z", id_cols = "id") |>
+ pivot_wider(
+ names_from = "qnum",
+ values_from = "score_z", id_cols = "id"
+ ) |>
select(starts_with("Q")) |>
as.matrix()
@@ -154,9 +172,11 @@ Then we can calculate a few other parameters. We want to calculate the variance
pca_data$var <- pca_data$sdev^2
pca_data$varexpl <- pca_data$var / sum(pca_data$var)
-pca_stats <- tibble(sdev = pca_data$sdev,
- var = pca_data$var,
- varexpl = pca_data$varexpl)
+pca_stats <- tibble(
+ sdev = pca_data$sdev,
+ var = pca_data$var,
+ varexpl = pca_data$varexpl
+)
```
We can visualize the variance captured in each component by creating a [scree plot](https://en.wikipedia.org/wiki/Scree_plot). This plot shows the components on the x-axis and the variance on the y-axis. Scree plots also typically include a horizontal line to indicate the eigenvalue of 1. Scree plots are typically interpreted based on the "elbow" in the plot, where the variance decreases. This can be a bit subjective. That's where the horizontal line comes in.
@@ -164,12 +184,14 @@ We can visualize the variance captured in each component by creating a [scree pl
```{r}
#| label: plot-var
-ggplot(pca_stats, aes(x = seq(var), y = var)) +
- geom_line(color = "grey30", size = 1) +
- geom_point(color = "grey30", size = 2) +
+ggplot(pca_stats, aes(x = seq(var), y = var)) +
+ geom_line(color = "grey30", linewidth = 1) +
+ geom_point(color = "grey30", size = 2) +
geom_hline(yintercept = 1, linetype = "dashed") +
- labs(x = "Principal component",
- y = "Variance (eigenvalue)") +
+ labs(
+ x = "Principal component",
+ y = "Variance (eigenvalue)"
+ ) +
theme_minimal()
```
@@ -178,13 +200,13 @@ It can be a bit hard to see from the plot how many components have an eigenvalue
```{r}
#| label: get-n-ics
-nICs <- pca_stats |>
+n_ics <- pca_stats |>
filter(var > 1) |>
nrow()
-print(nICs)
+print(n_ics)
```
-### Run ICA
+## Run ICA
Now we're ready to run the ICA! We'll use the `fastICA()` function. The function has a bunch of inputs. We'll pick the parallel algorithm (as opposed to the "deflation" algorithm). In the parallel algorithm the components are extracted simultaneously, with the deflation algorithm they're calculated one at a time. The "fun" option defines the form of the entropy function. I'm not 100% sure what it does. Just set it to `"exp"` and move on. For the `"method"` option there are two options: `"R"` or `"C"`. In the first option, all analyses are run in R, in the second option, all code is run in C, which is slightly faster. I typically use the `"C"` option. The `maxit` option defines the maximum number of iterations to perform. The default is 200, but in complex datasets, it may take a larger number of iterations to converge. That's why I set it to 5000. This process may take a while. If you want to follow along with what the algorithm is doing, you can set the `verbose` option to `TRUE`.
@@ -192,11 +214,14 @@ Now we're ready to run the ICA! We'll use the `fastICA()` function. The function
#| label: run-ica
set.seed(2020)
-ica_model <- fastICA(mat, n.comp = nICs, alg.typ = "parallel",
- fun = "exp", method = "C", maxit = 5000)
+
+ica_model <- fastICA(mat,
+ n.comp = n_ics, alg.typ = "parallel",
+ fun = "exp", method = "C", maxit = 5000
+)
```
-### Create Weight Matrix
+## Create Weight Matrix
So now we have run the ICA decomposition. The function provides a few outputs:
@@ -226,7 +251,7 @@ Then we can also have a quick look at hierarchical clustering. This is a process
#| label: show-hclust
weight_matrix <- data.frame(t(ica_model$A))
-names(weight_matrix) <- paste0("IC",seq(weight_matrix))
+names(weight_matrix) <- str_glue("IC{seq(weight_matrix)}")
dist_matrix <- dist(as.matrix(weight_matrix))
clust <- hclust(dist_matrix)
@@ -235,24 +260,43 @@ plot(clust)
What we can see from the dendrogram is that for instance question 16 (_"I gravitate towards introspection"_) and question 17 (_"I am more comfortable interacting online than in person"_) on the left are very similar. Question 3 (_"I like to play RPGs. (Ex. D&D)"_) is somewhat similar, but not as much as question 16 and 17. The same goes for question 1 and 4, question 11 and 19, and so on.
+{{{< sidenote br="1.5em" >}}}
+We'll also do some cleaning of the questions that will help us make the plot look nicer later
+{{{< /sidenote >}}}
+
```{r}
#| label: select-qs
codes <- loadcodes |>
- filter(str_detect(qnum, "Q"))
+ filter(str_detect(qnum, "Q")) |>
+ mutate(
+ question = str_remove_all(question, "\t"),
+ question = str_remove(question, "\\.$")
+ )
```
Next we'll plot the weight matrix. For that we first create a column with the question number, we'll then merge the matrix with the list of questions so we can plot the actual question asked instead of the question number. Next, we'll put the data frame in a long format. Finally, we'll also reorder the questions to match the order determined by the hierarchical clustering.
+{{{< sidenote br="4em" >}}}
+The `%>%` pipe is necessary here because the placeholder functions a bit differently from the R's native `|>` pipe
+{{{< /sidenote >}}}
+
```{r}
#| label: create-plotdata
weight_matrix_long <- weight_matrix |>
mutate(qnum = str_glue("Q{row_number()}")) |>
inner_join(codes, by = "qnum") |>
- pivot_longer(cols = starts_with("IC"), names_to = "IC", values_to = "loading") %>%
- mutate(question = as_factor(question),
- question = fct_relevel(question, unique(.$question)[clust$order]))
+ pivot_longer(
+ cols = starts_with("IC"),
+ names_to = "IC", values_to = "loading"
+ ) %>%
+ mutate(
+ question = fct_relevel(
+ question,
+ unique(.$question)[clust$order]
+ ),
+ )
```
So let's see what the ICA spit out. We'll make a plot where the questions are shown along the y-axis and where the x-axis shows their loading onto the different independent components. The orientation of the loading between the components does not have meaning, but within the components it can indicate that some questions have opposing effects. We'll reorder the x- and y-axis to order it based on the loading strength.
@@ -261,18 +305,26 @@ So let's see what the ICA spit out. We'll make a plot where the questions are sh
#| label: plot-wmatrix-nolabs
#| out.width: 100%
-ggplot(weight_matrix_long, aes(x = IC, y = question, fill = loading)) +
- geom_tile() +
- labs(x = NULL,
- y = NULL,
- fill = NULL) +
- scale_fill_gradient2(low = "#FF729F", mid = "black", high = "#7EE8FA", limits = c(-1, 1),
- guide = guide_colorbar(barwidth = 0.5, barheight = 15, ticks = FALSE)) +
- theme_minimal(base_size = 8) +
+weight_matrix_long |>
+ ggplot(aes(x = IC, y = question, fill = loading)) +
+ geom_tile() +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = NULL
+ ) +
+ scale_fill_gradient2(
+ low = "#FF729F", mid = "black", high = "#7EE8FA",
+ limits = c(-1, 1),
+ guide = guide_colorbar(
+ barwidth = 0.5,
+ barheight = 15, ticks = FALSE
+ )
+ ) +
+ theme_minimal(base_size = 10) +
theme(
legend.position = "right",
- panel.grid = element_blank(),
- axis.text.x = element_text(size = 6),
+ panel.grid = element_blank()
)
```
diff --git a/content/blog/2021-amsterdam-housing-market/MVA_kwartaalcijfers.xlsx b/content/blog/2021-amsterdam-housing-market/data/MVA_kwartaalcijfers.xlsx
similarity index 100%
rename from content/blog/2021-amsterdam-housing-market/MVA_kwartaalcijfers.xlsx
rename to content/blog/2021-amsterdam-housing-market/data/MVA_kwartaalcijfers.xlsx
diff --git a/content/blog/2021-amsterdam-housing-market/data/data_merged.rds b/content/blog/2021-amsterdam-housing-market/data/data_merged.rds
new file mode 100644
index 0000000..23f6364
--- /dev/null
+++ b/content/blog/2021-amsterdam-housing-market/data/data_merged.rds
@@ -0,0 +1,3 @@
+version https://git-lfs.github.com/spec/v1
+oid sha256:9db1e1602cd03957db7e3dcbd267786036acafdf3da162e70a4277dc8298128d
+size 21105
diff --git a/content/blog/2021-amsterdam-housing-market/data_merged.rds b/content/blog/2021-amsterdam-housing-market/data_merged.rds
deleted file mode 100644
index 8d36d14..0000000
Binary files a/content/blog/2021-amsterdam-housing-market/data_merged.rds and /dev/null differ
diff --git a/content/blog/2021-amsterdam-housing-market/index.md b/content/blog/2021-amsterdam-housing-market/index.md
index 5e4c4fd..1851b73 100644
--- a/content/blog/2021-amsterdam-housing-market/index.md
+++ b/content/blog/2021-amsterdam-housing-market/index.md
@@ -14,11 +14,13 @@ execute:
fig.show: hold
results: hold
dev.args: list(bg = "#EBEBEB")
+editor_options:
+ chunk_output_type: console
---
--For this post, I decided to hide the code chunks by default to improve legibility. You can click the Show code-button to expand the code. -
+ +{{< standout bg="#acc8d4" >}} +For this post, I decided to hide the code chunks by default to improve legibility. You can click on *Show code* to expand the code. +{{< /standout >}} ### Introduction I'm at the age where a lot of my peers start thinking about buying a home. It is a major conversation topic around the office, and these conversations are not often filled with optimism and excitement. Oslo is a notoriously expensive city to live in, and the housing market is very tough. -Of all the worrying events in 2020, Millenials and Gen Z kids ranked financial instability as the second most common driver of stress, the most common being the welfare of their family ([link](https://www2.deloitte.com/global/en/pages/about-deloitte/articles/millennialsurvey.html)). Today I want to dissect one of the possible causes of this *economic anxiety*: **the housing market**. Now, I'm not an economist nor a financial expert. Nonetheless, I believe I can leverage some of my knowledge of data wrangling and analysis to contribute a small piece to this topic. My insight into the Oslo housing market is fairly limited to so far and there's many nuances I don't fully understand yet, but I do think I have some relevant knowledge of the Dutch housing market. So today I'll dive into some data on the Dutch market, and particularly the Amsterdam housing market. There's countless stories about the Amsterdam housing market and how terrible it is for new buyers, similar to the Oslo housing market. However, in my opinion the Amsterdam housing market is already a few steps ahead of the Oslo market, and hopefully the Amsterdam market can offer some warnings about what the Oslo housing market might look like in a few years without some policy corrections. +{{< sidenote >}} +This conclusion is based on a survey from Deloitte in 2020 where they surveyed millennials and Gen Z kids both before and after the onset of the pandemic +{{< /sidenote >}} + +Of all the worrying events in 2020, millennials and Gen Z kids ranked financial instability as the second most common driver of stress, the most common being the welfare of their family ([source](https://www2.deloitte.com/content/dam/Deloitte/global/Documents/About-Deloitte/deloitte-2020-millennial-survey.pdf)). Today I want to dissect one of the possible causes of this *economic anxiety*: **the housing market**. Now, I'm not an economist nor a financial expert. Nonetheless, I believe I can leverage some of my knowledge of data wrangling and analysis to contribute a small piece to this topic. My insight into the Oslo housing market is fairly limited to so far and there's many nuances I don't fully understand yet, but I do think I have some relevant knowledge of the Dutch housing market. So today I'll dive into some data on the Dutch market, and particularly the Amsterdam housing market. There's countless stories about the Amsterdam housing market and how terrible it is for new buyers, similar to the Oslo housing market. However, in my opinion the Amsterdam housing market is already a few steps ahead of the Oslo market, and hopefully the Amsterdam market can offer some warnings about what the Oslo housing market might look like in a few years without some policy corrections. This will be a fairly basic data analysis and visualization post, I can't claim that this is an exhaustive list and that I didn't miss some nuances, but I'll give it . I collected some data from the Amsterdam Real Estate Association ([Makelaars Vereniging Amsterdam; MVA](https://www.mva.nl)) and statistics from the Central Bureau for Statistics ([Centraal Bureau for de Statistiek; CBS](https://www.cbs.nl)). As usual, I'll be using `{tidyverse}` *a lot*. I've also recently started using the `{ggtext}` package to manage the text elements in my plots, inspired by Cédric Scherer ([@CedScherer](https://twitter.com/CedScherer)). I'll use the `{gt}` package to spice up some of the tables, and `{patchwork}` for arranging plots. I'll use the `{cbsodataR}` to download data from the Central Bureau for Statistics ([CBS](https://www.cbs.nl)). @@ -60,27 +67,46 @@ font_add_google(name = "Nunito Sans", family = "nunito-sans") showtext_auto() theme_set(ggthemes::theme_economist(base_family = "nunito-sans") + - theme(rect = element_rect(fill = "#EBEBEB", color = "transparent"), - plot.background = element_rect(fill = "#EBEBEB", color = "transparent"), - panel.background = element_rect(fill = "#EBEBEB", color = "transparent"), - plot.title = element_textbox(margin = margin(0,0,5,0,"pt")), - plot.title.position = "plot", - plot.subtitle = element_textbox(hjust = 0, margin = margin(0,0,15,0,"pt")), - plot.caption = element_textbox(hjust = 1), - plot.caption.position = "plot", - axis.title.y = element_textbox(orientation = "left-rotated", face = "bold", - margin = margin(0,0,5,0,"pt")), - axis.text.y = element_text(hjust = 1), - legend.position = "bottom", - legend.box = "vertical", - legend.text = element_text(size = 10))) + theme( + rect = element_rect(fill = "#EBEBEB", color = "transparent"), + plot.background = element_rect( + fill = "#EBEBEB", + color = "transparent" + ), + panel.background = element_rect( + fill = "#EBEBEB", + color = "transparent" + ), + plot.title = element_textbox( + margin = margin(0, 0, 5, 0, "pt") + ), + plot.title.position = "plot", + plot.subtitle = element_textbox( + hjust = 0, + margin = margin(0, 0, 15, 0, "pt") + ), + plot.caption = element_textbox(hjust = 1), + plot.caption.position = "plot", + axis.title.y = element_textbox( + orientation = "left-rotated", face = "bold", + margin = margin(0, 0, 5, 0, "pt") + ), + axis.text.y = element_text(hjust = 1), + legend.position = "bottom", + legend.box = "vertical", + legend.text = element_text(size = 10) + )) ``` ### Getting the data -The first piece of data I'll use comes from the Amsterdam Real Estate Association. They publish quarterly data on a number of variables about the Amsterdam housing market ([link](https://www.mva.nl/over-de-mva/mva/kwartaalcijfers)), inclusing asking price, final price paid, number of properties put on the market, number of properties sold and a few more back to the first quarter of 2012. *Obviously*, these numbers all come in pdf-format, because the people writing quarterly reports apparently have a *massive hatred* towards people that want to analyze this data. I downloaded the reports, used the online tool [PDFTables](https://pdftables.com) to convert them to Excel, and then stitched the tables together manually. Of course (remember the authors have a *massive hatred* towards us), the formatting of the numbers in the tables weren't consistent between different quarterly reports, so I had to do some cleaning in R. I put each table in a separate sheet and then used functionality from the `{readxl}` package to load each table into a different variable and then do the cleaning per table. This was a bit cumbersome. Since this will probably be a very long post, I'll hide the code, but you can see it in the [Rmarkdown file](https://github.com/danielroelfs/danielroelfs.com/blob/main/content/blog/2020-running-an-ica-on-questionnaires/index.Rmd) (at least until I figure out how to get code folding to work on my laptop). +{{< sidenote br="10em" >}} +There are [R packages](https://docs.ropensci.org/tabulizer/) that can parse PDF files, but in my experience they can be clunky. In this case the simplest solution seemed the best, despite requiring some manual work +{{< /sidenote >}} + +The first piece of data I'll use comes from the Amsterdam Real Estate Association. They publish quarterly data on a number of variables about the Amsterdam housing market ([link](https://www.mva.nl/over-de-mva/mva/kwartaalcijfers)), inclusing asking price, final price paid, number of properties put on the market, number of properties sold and a few more back to the first quarter of 2012. *Obviously*, these numbers all come in pdf-format, because the people writing quarterly reports apparently have a *massive hatred* towards people that want to analyze this data. I downloaded the reports, used the online tool [PDFTables](https://pdftables.com) to convert them to Excel, and then stitched the tables together manually. Of course (remember the authors have a *massive hatred* towards us), the formatting of the numbers in the tables weren't consistent between different quarterly reports, so I had to do some cleaning in R. I put each table in a separate sheet and then used functionality from the `{readxl}` package to load each table into a different variable and then do the cleaning per table. This was a bit cumbersome. You can look at the code I used to load and merge the files. It's a bit of a mess: @@ -88,61 +114,135 @@ You can look at the code I used to load and merge the files. It's a bit of a mesShow code
``` r -colors <- c("#019868","#9dd292","#ec0b88","#651eac","#e18a1e","#2b7de5") - -data |> - filter(type != "Total") |> - group_by(type) |> - mutate(n_total = sum(n_sold), - type_label = str_glue("{type} (n={format(n_total, big.mark = \".\", decimal.mark = \",\")})"), - type_label = str_replace(type_label,"\\) \\(", ", ")) |> - arrange(type) |> - mutate(type_label = factor(type_label)) |> - ggplot(aes(x = date, y = diff_ask_paid_perc, color = type_label)) + +colors <- c("#019868", "#9dd292", "#ec0b88", "#651eac", "#e18a1e", "#2b7de5") + +data |> + filter(type != "Total") |> + group_by(type) |> + mutate( + n_total = sum(n_sold), + type_label = str_glue( + "{type} (n={format(n_total, big.mark = \".\", decimal.mark = \",\")})" + ), + type_label = str_replace(type_label, "\\) \\(", ", ") + ) |> + arrange(type) |> + mutate(type_label = factor(type_label)) |> + ggplot(aes(x = date, y = diff_ask_paid_perc, color = type_label)) + geom_hline(yintercept = 0, color = "grey30", size = 1) + - geom_line(size = 1.2, alpha = 0.8, lineend = "round", key_glyph = "point") + - labs(title = "Overbidding has become the new normal", - subtitle = "_Paying as much as 5% over asking price is common the past few years_", - x = NULL, - y = "Percentage difference between\nasking price and price paid", - color = NULL, - caption = "_**Data**: MVA_") + - scale_y_continuous(labels = scales::label_percent()) + - scale_color_manual(values = colors, - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(fill = "transparent", size = 6, alpha = 1))) + - theme(plot.title = element_textbox(size = 20), - axis.title.y = element_textbox(width = grid::unit(2.5, "in")), - legend.key = element_rect(fill = "transparent", color = "transparent")) + geom_line( + size = 1.2, alpha = 0.8, + lineend = "round", key_glyph = "point" + ) + + labs( + title = "Overbidding has become the new normal", + subtitle = "_Paying as much as 5% over asking price is common the past few years_", + x = NULL, + y = "Percentage difference between\nasking price and price paid", + color = NULL, + caption = "_**Data**: MVA_" + ) + + scale_y_continuous(labels = scales::label_percent()) + + scale_color_manual( + values = colors, + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list(fill = "transparent", size = 6, alpha = 1) + ) + ) + + theme( + plot.title = element_textbox(size = 20), + axis.title.y = element_textbox(width = grid::unit(2.5, "in")), + legend.key = element_rect(fill = "transparent", color = "transparent") + ) ```Property type
"), diff_ask_paid_perc = html("Percentage overpay
"), diff_ask_paid = html("Mean overpay
"), transaction_price = html("Mean transaction price
"), n_sold = html("Number of properties
sold in period
")
- ) |>
- tab_header(title = html("Difference between
asking price and price paid
"),
- subtitle = html("Data from the first quarter of 2021
")) |> - tab_source_note(source_note = md("_**Data**: MVA_")) |> + ) |> + tab_header( + title = html("Difference between
asking price and price paid
"),
+ subtitle = html("Data from the first quarter of 2021
") + ) |> + tab_source_note(source_note = md("_**Data**: MVA_")) |> tab_options(table.background.color = "#EBEBEB") |> gtsave("overpay-table.png", expand = 0) ``` @@ -302,42 +440,69 @@ What contributed to this price increase? A simple supply-and-demand plays a part-A new phenomenon that entered the scene a little while ago may indicate how skewed the market is. People wanting to buy a house in a certain neighborhood will put notes and letters in the mailboxes of people living in that area saying "Nice house! Are you interested in selling it to me?". This is now not an uncommon strategy to find a house. Some people living in popular neighborshoods are inundated with notes from agencies facilitating these practices. See also a news item by RTL. -
+{{< standout bg="#acc8d4" >}} +A new phenomenon that entered the scene a little while ago may indicate how skewed the market is. People wanting to buy a house in a certain neighborhood will put notes and letters in the mailboxes of people living in that area saying *"Nice house! Are you interested in selling it to me?"*. This is now not an uncommon strategy to find a house. Some people living in popular neighborshoods are inundated with notes from agencies facilitating these practices. See also a [news item by RTL](https://www.rtlnieuws.nl/geld-en-werk/artikel/19001/droomhuis-gezien-maar-niet-te-koop-stop-dan-een-briefje-de-bus) +{{< /standout >}} +Show code
``` r -data |> - filter(type != "Total") |> - ggplot(aes(x = date, y = perc_sold, fill = type)) + - geom_col(key_glyph = "point") + +data |> + filter(type != "Total") |> + ggplot(aes(x = date, y = perc_sold, fill = type)) + + geom_col(key_glyph = "point") + geom_hline(yintercept = 1, linetype = "dashed", color = "grey20") + - labs(title = "Some years, more houses are sold than are being put on the market", - x = NULL, - y = "Percentage of offered houses sold", - fill = NULL, - caption = "_**Data**: MVA_") + + labs( + title = "Some years, more houses are sold than are being put on the market", + x = NULL, + y = "Percentage of offered houses sold", + fill = NULL, + caption = "_**Data**: MVA_" + ) + coord_cartesian(clip = "off") + - scale_y_continuous(labels = scales::label_percent(), expand = c(0,NA), n.breaks = 4) + - scale_fill_manual(values = colors, - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(shape = 21, size = 6, alpha = 1, stroke = 0))) + - theme(plot.title = element_textbox(size = 20, - width = grid::unit(6,"in")), - plot.subtitle = element_textbox(size = 10), - strip.text.x = element_markdown(face = "bold", padding = margin(10,0,5,0,"pt")), - strip.background = element_rect(fill = "transparent"), - legend.key = element_rect(fill = "transparent")) + - facet_wrap(~ type, strip.position = "top", scales = "free_x") + scale_y_continuous( + labels = scales::label_percent(), + expand = c(0, NA), n.breaks = 4 + ) + + scale_fill_manual( + values = colors, + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list(shape = 21, size = 6, alpha = 1, stroke = 0) + ) + ) + + theme( + plot.title = element_textbox( + size = 20, + width = grid::unit(6, "in") + ), + plot.subtitle = element_textbox(size = 10), + strip.text.x = element_markdown( + face = "bold", + padding = margin(10, 0, 5, 0, "pt") + ), + strip.background = element_rect(fill = "transparent"), + legend.key = element_rect(fill = "transparent") + ) + + facet_wrap(~type, strip.position = "top", scales = "free_x") ```
@@ -456,7 +675,8 @@ But that's not all, there's a few other features that contribute to the gridlock
``` r
house_mutations_in <- tribble(
- ~year, ~buy_to_rent_corp, ~buy_to_rent_other, ~rent_corp_to_buy, ~rent_corp_to_rent_other, ~rent_other_to_buy, ~rent_other_to_rent_corp,
+ ~year, ~buy_to_rent_corp, ~buy_to_rent_other, ~rent_corp_to_buy,
+ ~rent_corp_to_rent_other, ~rent_other_to_buy, ~rent_other_to_rent_corp,
2012, 900, 58000, 14600, 5500, 50600, 4900,
2013, 800, 62200, 15200, 11500, 50900, 6000,
2014, 1000, 62200, 15400, 9300, 59900, 39000,
@@ -465,19 +685,28 @@ house_mutations_in <- tribble(
2017, 1600, 98900, 6400, 11000, 7300, 9000
)
-house_mutations <- house_mutations_in |>
- pivot_longer(cols = -year, names_to = "mutation", values_to = "n_mutations") |>
- mutate(from = str_extract(mutation, "(.*?)_to"),
- from = str_remove_all(from, "_to"),
- to = str_extract(mutation, "to_(.*?)$"),
- to = str_remove_all(to, "to_")) |>
- group_by(year) |>
- mutate(total_mutations = sum(n_mutations),
- perc_mutations = n_mutations / total_mutations,
- across(c(from,to), ~ case_when(str_detect(.x,"buy") ~ "buy",
- str_detect(.x,"rent_corp") ~ "rent (corporation)",
- str_detect(.x,"rent_other") ~ "rent (other)")),
- mutation_label = str_glue("From {from} to {to}")) |>
+house_mutations <- house_mutations_in |>
+ pivot_longer(
+ cols = -year,
+ names_to = "mutation", values_to = "n_mutations"
+ ) |>
+ mutate(
+ from = str_extract(mutation, "(.*?)_to"),
+ from = str_remove_all(from, "_to"),
+ to = str_extract(mutation, "to_(.*?)$"),
+ to = str_remove_all(to, "to_")
+ ) |>
+ group_by(year) |>
+ mutate(
+ total_mutations = sum(n_mutations),
+ perc_mutations = n_mutations / total_mutations,
+ across(c(from, to), ~ case_when(
+ str_detect(.x, "buy") ~ "buy",
+ str_detect(.x, "rent_corp") ~ "rent (corporation)",
+ str_detect(.x, "rent_other") ~ "rent (other)"
+ )),
+ mutation_label = str_glue("From {from} to {to}")
+ ) |>
ungroup()
```
@@ -489,46 +718,77 @@ So not every year there's the same number of "mutations" (transformations of pur
- Warning: Since gt v0.9.0, the `formatter` argument (and associated `...`) has been
- deprecated.
- • Please use the `fmt` argument to provide formatting directives.
- This warning is displayed once every 8 hours.
-
So what's the result of all these phenomena? The figure below shows the housing price index for Amsterdam. The first quarter of 2012 was taken as the reference point (100%). In the past 8(!) years, properties had on average nearly doubled in price.
Show code
``` r -mutations_n_plot <- house_mutations |> - arrange(from,to) |> - mutate(mutation_label = fct_inorder(mutation_label)) |> - ggplot(aes(x = year, y = n_mutations, alluvium = mutation_label, fill = mutation_label)) + +mutations_n_plot <- house_mutations |> + arrange(from, to) |> + mutate(mutation_label = fct_inorder(mutation_label)) |> + ggplot(aes( + x = year, y = n_mutations, + alluvium = mutation_label, fill = mutation_label + )) + geom_point(shape = 21, color = "transparent", size = NA) + ggalluvial::geom_flow(width = 0, show.legend = FALSE) + - labs(x = NULL, - y = "Number of mutations", - fill = NULL) + - scale_x_continuous(expand = c(0,0)) + - scale_y_continuous(labels = scales::label_number_auto(), expand = c(0,0)) + - scale_fill_manual(values = rev(colors), - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(color = "transparent", size = 6, alpha = 1, stroke = 0))) + + labs( + x = NULL, + y = "Number of mutations", + fill = NULL + ) + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous( + labels = scales::label_number_auto(), + expand = c(0, 0) + ) + + scale_fill_manual( + values = rev(colors), + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list( + color = "transparent", size = 6, + alpha = 1, stroke = 0 + ) + ) + ) + theme(legend.key = element_rect(fill = "transparent")) -mutations_perc_plot <- house_mutations |> - arrange(from,to) |> - mutate(mutation_label = fct_inorder(mutation_label)) |> - ggplot(aes(x = year, y = perc_mutations, alluvium = mutation_label, fill = mutation_label)) + +mutations_perc_plot <- house_mutations |> + arrange(from, to) |> + mutate(mutation_label = fct_inorder(mutation_label)) |> + ggplot(aes( + x = year, y = perc_mutations, + alluvium = mutation_label, fill = mutation_label + )) + geom_point(shape = 21, color = "transparent", size = NA) + ggalluvial::geom_flow(width = 0, show.legend = FALSE) + - labs(x = NULL, - y = "Percentage of total mutations per quarter", - fill = NULL) + - scale_x_continuous(expand = c(0,0)) + - scale_y_continuous(labels = scales::label_percent(), expand = c(0,0)) + - scale_fill_manual(values = rev(colors), - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(color = "transparent", size = 6, alpha = 1, stroke = 0))) + - theme(axis.title.y = element_textbox(width = grid::unit(2,"in")), - legend.key = element_rect(fill = "transparent")) + labs( + x = NULL, + y = "Percentage of total mutations per quarter", + fill = NULL + ) + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous(labels = scales::label_percent(), expand = c(0, 0)) + + scale_fill_manual( + values = rev(colors), + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list( + color = "transparent", size = 6, + alpha = 1, stroke = 0 + ) + ) + ) + + theme( + axis.title.y = element_textbox(width = grid::unit(2, "in")), + legend.key = element_rect(fill = "transparent") + ) mutations_n_plot / mutations_perc_plot + - plot_annotation(title = "Shift to a renters market", - subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", - caption = "_**Data**: CBS_") + - plot_layout(guides = 'collect') & + plot_annotation( + title = "Shift to a renters market", + subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", + caption = "_**Data**: CBS_" + ) + + plot_layout(guides = "collect") & theme(plot.title = element_textbox(size = 20)) ``` @@ -544,51 +804,65 @@ We can look at the net number of houses added to the rental market by adding upShow code
``` r -net_house_mutations <- house_mutations |> - mutate(across(c(from,to), ~ case_when(str_detect(.x, "rent") ~ "rent", - str_detect(.x, "buy") ~ "buy"))) |> - group_by(year) |> - filter(from != to) |> - mutate(total_mutations = sum(n_mutations)) |> - group_by(year, from, to) |> - summarise(n_mutations = sum(n_mutations), - total_mutations = first(total_mutations)) |> - pivot_wider(id_cols = c(year,total_mutations), names_from = c(from,to), values_from = n_mutations, - names_sep = "_to_") |> - mutate(net_buy_to_rent = buy_to_rent - rent_to_buy, - perc_buy_to_rent = buy_to_rent / total_mutations) - -net_mutation_plot <- net_house_mutations |> - ggplot(aes(x = year, y = net_buy_to_rent)) + +net_house_mutations <- house_mutations |> + mutate(across(c(from, to), ~ case_when( + str_detect(.x, "rent") ~ "rent", + str_detect(.x, "buy") ~ "buy" + ))) |> + group_by(year) |> + filter(from != to) |> + mutate(total_mutations = sum(n_mutations)) |> + group_by(year, from, to) |> + summarise( + n_mutations = sum(n_mutations), + total_mutations = first(total_mutations) + ) |> + pivot_wider( + id_cols = c(year, total_mutations), + names_from = c(from, to), + values_from = n_mutations, + names_sep = "_to_" + ) |> + mutate( + net_buy_to_rent = buy_to_rent - rent_to_buy, + perc_buy_to_rent = buy_to_rent / total_mutations + ) + +net_mutation_plot <- net_house_mutations |> + ggplot(aes(x = year, y = net_buy_to_rent)) + geom_hline(yintercept = 0, color = "grey30", size = 1) + - #geom_ribbon(aes(ymin = 0, ymax = net_buy_to_rent), fill = "grey30", alpha = 0.2) + geom_line(color = "darkred", size = 1.5, lineend = "round") + - #geom_textbox(data = tibble(), aes(x = 2014, y = 4e4, - # label = "Net number of properties meant for sale withdrawn from the market"), - # family = "nunito-sans", size = 4, fill = "transparent", - # maxwidth = grid::unit(2,"in"), hjust = 0.5, vjust = 0) + - #geom_curve(data = tibble(), aes(x = 2014, y = 4e4, xend = 2016.5, yend = 2.5e4), - # curvature = 0.3, size = 0.75, arrow = arrow(length = unit(2,"mm")), - # lineend = "round") + - labs(x = NULL, - y = "**Net number of properties changed from properties meant for sale to rental properties**") + - scale_y_continuous(labels = scales::label_number_auto(), limits = c(-3e4, NA), n.breaks = 5) + - theme(axis.title.y = element_textbox(width = grid::unit(3.5,"in"))) - -perc_mutation_plot <- net_house_mutations |> - ggplot(aes(x = year, y = perc_buy_to_rent)) + + labs( + x = NULL, + y = "**Net number of properties changed from properties meant for sale to rental properties**" + ) + + scale_y_continuous( + labels = scales::label_number_auto(), + limits = c(-3e4, NA), n.breaks = 5 + ) + + theme(axis.title.y = element_textbox(width = grid::unit(3.5, "in"))) + +perc_mutation_plot <- net_house_mutations |> + ggplot(aes(x = year, y = perc_buy_to_rent)) + geom_hline(yintercept = 0.5, color = "grey30", size = 1) + geom_line(color = "darkred", size = 1.5, lineend = "round") + - labs(x = NULL, - y = "**Percentage of mutations that changed properties meant for sale to rental properties**") + - scale_y_continuous(labels = scales::label_percent(), limits = c(0,1), expand = c(0,0)) + + labs( + x = NULL, + y = "**Percentage of mutations that changed properties meant for sale to rental properties**" + ) + + scale_y_continuous( + labels = scales::label_percent(), + limits = c(0, 1), expand = c(0, 0) + ) + coord_cartesian(clip = "off") + - theme(axis.title.y = element_textbox(width = grid::unit(3.5,"in"))) - -net_mutation_plot + perc_mutation_plot + - plot_annotation(title = "Major net shift towards rental market", - subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", - caption = "_**Data**: CBS_") & + theme(axis.title.y = element_textbox(width = grid::unit(3.5, "in"))) + +net_mutation_plot + perc_mutation_plot + + plot_annotation( + title = "Major net shift towards rental market", + subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", + caption = "_**Data**: CBS_" + ) & theme(plot.title = element_textbox(size = 20)) ``` @@ -602,97 +876,123 @@ So in 2017 nearly 90 000 houses were mutated from sale to rental properties. InShow code
``` r -house_mutations |> - filter(year == max(year)) |> - select(from, to, n_mutations, perc_mutations) |> - mutate(across(c(from,to), ~ str_to_sentence(.x))) |> - arrange(-perc_mutations) |> - gt() |> - fmt_number(columns = "n_mutations", sep_mark = " ", drop_trailing_zeros = TRUE) |> - fmt_percent(columns = "perc_mutations") |> +house_mutations |> + filter(year == max(year)) |> + select(from, to, n_mutations, perc_mutations) |> + mutate(across(c(from, to), ~ str_to_sentence(.x))) |> + arrange(-perc_mutations) |> + gt() |> + fmt_number( + columns = "n_mutations", sep_mark = " ", + drop_trailing_zeros = TRUE + ) |> + fmt_percent(columns = "perc_mutations") |> grand_summary_rows( columns = "n_mutations", fns = list(total = "sum"), - formatter = fmt_number, + fmt = ~ fmt_number(.), sep_mark = " ", - drop_trailing_zeros = TRUE) |> + drop_trailing_zeros = TRUE + ) |> grand_summary_rows( columns = "perc_mutations", fns = list(total = "sum"), - formatter = fmt_percent, - missing_text = "") |> + fmt = ~ fmt_percent(.), + missing_text = "" + ) |> cols_label( from = html("From
"), to = html("To
"), n_mutations = html("Number of mutations
"), perc_mutations = html("Percentage of total mutations
") - ) |> - tab_header(title = html("Mutations in the Dutch housing market
"), - subtitle = html("Data from the year 2017
")) |> - tab_source_note(source_note = md("_**Data**: CBS_")) |> - tab_options(table.background.color = "#EBEBEB", - grand_summary_row.text_transform = "capitalize") |> + ) |> + tab_header( + title = html( + "Mutations in the Dutch housing market
" + ), + subtitle = html( + "Data from the year 2017
" + ) + ) |> + tab_source_note(source_note = md("_**Data**: CBS_")) |> + tab_options( + table.background.color = "#EBEBEB", + grand_summary_row.text_transform = "capitalize" + ) |> gtsave("mutations-table.png", expand = 0) ```Show code
``` r -asking_start <- data |> - filter(type != "Total", - date == min(date)) |> - rename(asking_start = asking_price) |> +asking_start <- data |> + filter( + type != "Total", + date == min(date) + ) |> + rename(asking_start = asking_price) |> select(type, asking_start) -data_asking_index <- data |> - filter(type != "Total") |> - left_join(asking_start) |> +data_asking_index <- data |> + filter(type != "Total") |> + left_join(asking_start) |> mutate(asking_index = asking_price / asking_start) -data_asking_index |> - ggplot(aes(x = date, y = asking_index, color = type, group = type)) + - geom_line(size = 2, alpha = 0.15, lineend = "round", show.legend = FALSE) + +data_asking_index |> + ggplot(aes(x = date, y = asking_index, color = type, group = type)) + + geom_line(size = 2, alpha = 0.15, lineend = "round", show.legend = FALSE) + geom_smooth(se = FALSE, show.legend = FALSE) + - geom_point(size = NA) + - labs(title = "Price development over the past decade", - subtitle = "_On average, properties doubled in value since 2012_", - x = NULL, - y = "Price development relative to early 2012", - color = NULL, - caption = "_**Data**: MVA_") + - scale_y_continuous(labels = scales::label_percent()) + - scale_color_manual(values = colors, - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(fill = "transparent", size = 6, alpha = 1))) + - theme(plot.title = element_textbox(size = 20), - axis.title.y = element_textbox(width = grid::unit(2.5, "in")), - legend.key = element_rect(fill = "transparent", color = "transparent")) + geom_point(size = NA) + + labs( + title = "Price development over the past decade", + subtitle = "_On average, properties doubled in value since 2012_", + x = NULL, + y = "Price development relative to early 2012", + color = NULL, + caption = "_**Data**: MVA_" + ) + + scale_y_continuous(labels = scales::label_percent()) + + scale_color_manual( + values = colors, + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list(fill = "transparent", size = 6, alpha = 1) + ) + ) + + theme( + plot.title = element_textbox(size = 20), + axis.title.y = element_textbox(width = grid::unit(2.5, "in")), + legend.key = element_rect(fill = "transparent", color = "transparent") + ) ```
-Adjusted for the number of properties offered, the average asking price in Amsterdam has increased by 107%. That means that prices since 2012 have (on average) doubled. For apartments, this increase was 110%. Inflation on the other hand was only about 8.5% since 2012. So young people wanting to buy a house in Amsterdam need to bring nearly twice as much money to the table as they did just a decade ago. The money they saved and the salaries they earned have by no means kept up with the increasing price though.
+{{< sidenote >}}
+Inflation since 2012 was about 8.5% which should be subtracted from these values
+{{< /sidenote >}}
+
+Adjusted for the number of properties offered, the average asking price in Amsterdam has increased by 107%. That means that prices since 2012 have (on average) roughly doubled. For apartments, this increase was 110%. So young people wanting to buy a house in Amsterdam need to bring nearly twice as much money to the table as they did just a decade ago. The money they saved and the salaries they earned have by no means kept up with the increasing price though.
I cannot know this for sure, because the data I presented here doesn't contain the answer, but perhaps these factors combined play a role in the financial uncertainty that millenials experience. How do we fix it? I'm not sure. This is a really complicated issue. But a few things might (in my opinion) help:
-1. **Build more (sustainable) durable houses**
-2. **Prohibit sale of properties to individuals who don't plan to live there themselves for at least 2 or 3 years**
-3. **Increase transparency when buying or selling a house through mandatory public offerings to prevent scooping by investors**
-4. **Rent control to make *"mutating"* houses less profitable**
-5. **Increased socialized housing for poor and low-income families**
+- **Build more (sustainable) durable houses**
+
+- **Prohibit sale of properties to individuals who don't plan to live there themselves for at least 2 or 3 years**
+
+- **Increase transparency when buying or selling a house through mandatory public offerings to prevent scooping by investors**
+
+- **Rent control to make *"mutating"* houses less profitable**
+
+- **Increased socialized housing for poor and low-income families**
Perhaps if we implement a few of these strategies we can make the housing market a little fairer and perhaps ensure that future generations will have the same opportunities current home-owners have.
diff --git a/content/blog/2021-amsterdam-housing-market/index.qmd b/content/blog/2021-amsterdam-housing-market/index.qmd
index bb897de..41a3c2b 100644
--- a/content/blog/2021-amsterdam-housing-market/index.qmd
+++ b/content/blog/2021-amsterdam-housing-market/index.qmd
@@ -14,6 +14,8 @@ execute:
fig.show: hold
results: hold
dev.args: list(bg = "#EBEBEB")
+editor_options:
+ chunk_output_type: console
---
```{css}
@@ -21,7 +23,7 @@ execute:
#| echo: FALSE
body {
- background-color: #EBEBEB; /* was #EFEFEF */
+ background-color: #EBEBEB;
}
table {
@@ -37,13 +39,19 @@ img {
}
```
-For this post, I decided to hide the code chunks by default to improve legibility. You can click the Show code-button to expand the code.
+{{{< standout bg="#acc8d4" >}}} +For this post, I decided to hide the code chunks by default to improve legibility. You can click on _Show code_ to expand the code. +{{{< /standout >}}} ### Introduction -I'm at the age where a lot of my peers start thinking about buying a home. It is a major conversation topic around the office, and these conversations are not often filled with optimism and excitement. Oslo is a notoriously expensive city to live in, and the housing market is very tough. +I'm at the age where a lot of my peers start thinking about buying a home. It is a major conversation topic around the office, and these conversations are not often filled with optimism and excitement. Oslo is a notoriously expensive city to live in, and the housing market is very tough. -Of all the worrying events in 2020, Millenials and Gen Z kids ranked financial instability as the second most common driver of stress, the most common being the welfare of their family ([link](https://www2.deloitte.com/global/en/pages/about-deloitte/articles/millennialsurvey.html)). Today I want to dissect one of the possible causes of this _economic anxiety_: **the housing market**. Now, I'm not an economist nor a financial expert. Nonetheless, I believe I can leverage some of my knowledge of data wrangling and analysis to contribute a small piece to this topic. My insight into the Oslo housing market is fairly limited to so far and there's many nuances I don't fully understand yet, but I do think I have some relevant knowledge of the Dutch housing market. So today I'll dive into some data on the Dutch market, and particularly the Amsterdam housing market. There's countless stories about the Amsterdam housing market and how terrible it is for new buyers, similar to the Oslo housing market. However, in my opinion the Amsterdam housing market is already a few steps ahead of the Oslo market, and hopefully the Amsterdam market can offer some warnings about what the Oslo housing market might look like in a few years without some policy corrections. +{{{< sidenote >}}} +This conclusion is based on a survey from Deloitte in 2020 where they surveyed millennials and Gen Z kids both before and after the onset of the pandemic +{{{< /sidenote >}}} + +Of all the worrying events in 2020, millennials and Gen Z kids ranked financial instability as the second most common driver of stress, the most common being the welfare of their family ([source](https://www2.deloitte.com/content/dam/Deloitte/global/Documents/About-Deloitte/deloitte-2020-millennial-survey.pdf)). Today I want to dissect one of the possible causes of this _economic anxiety_: **the housing market**. Now, I'm not an economist nor a financial expert. Nonetheless, I believe I can leverage some of my knowledge of data wrangling and analysis to contribute a small piece to this topic. My insight into the Oslo housing market is fairly limited to so far and there's many nuances I don't fully understand yet, but I do think I have some relevant knowledge of the Dutch housing market. So today I'll dive into some data on the Dutch market, and particularly the Amsterdam housing market. There's countless stories about the Amsterdam housing market and how terrible it is for new buyers, similar to the Oslo housing market. However, in my opinion the Amsterdam housing market is already a few steps ahead of the Oslo market, and hopefully the Amsterdam market can offer some warnings about what the Oslo housing market might look like in a few years without some policy corrections. This will be a fairly basic data analysis and visualization post, I can't claim that this is an exhaustive list and that I didn't miss some nuances, but I'll give it . I collected some data from the Amsterdam Real Estate Association ([Makelaars Vereniging Amsterdam; MVA](https://www.mva.nl)) and statistics from the Central Bureau for Statistics ([Centraal Bureau for de Statistiek; CBS](https://www.cbs.nl)). As usual, I'll be using `{tidyverse}` _a lot_. I've also recently started using the `{ggtext}` package to manage the text elements in my plots, inspired by Cédric Scherer ([@CedScherer](https://twitter.com/CedScherer)). I'll use the `{gt}` package to spice up some of the tables, and `{patchwork}` for arranging plots. I'll use the `{cbsodataR}` to download data from the Central Bureau for Statistics ([CBS](https://www.cbs.nl)). @@ -64,25 +72,44 @@ font_add_google(name = "Nunito Sans", family = "nunito-sans") showtext_auto() theme_set(ggthemes::theme_economist(base_family = "nunito-sans") + - theme(rect = element_rect(fill = "#EBEBEB", color = "transparent"), - plot.background = element_rect(fill = "#EBEBEB", color = "transparent"), - panel.background = element_rect(fill = "#EBEBEB", color = "transparent"), - plot.title = element_textbox(margin = margin(0,0,5,0,"pt")), - plot.title.position = "plot", - plot.subtitle = element_textbox(hjust = 0, margin = margin(0,0,15,0,"pt")), - plot.caption = element_textbox(hjust = 1), - plot.caption.position = "plot", - axis.title.y = element_textbox(orientation = "left-rotated", face = "bold", - margin = margin(0,0,5,0,"pt")), - axis.text.y = element_text(hjust = 1), - legend.position = "bottom", - legend.box = "vertical", - legend.text = element_text(size = 10))) + theme( + rect = element_rect(fill = "#EBEBEB", color = "transparent"), + plot.background = element_rect( + fill = "#EBEBEB", + color = "transparent" + ), + panel.background = element_rect( + fill = "#EBEBEB", + color = "transparent" + ), + plot.title = element_textbox( + margin = margin(0, 0, 5, 0, "pt") + ), + plot.title.position = "plot", + plot.subtitle = element_textbox( + hjust = 0, + margin = margin(0, 0, 15, 0, "pt") + ), + plot.caption = element_textbox(hjust = 1), + plot.caption.position = "plot", + axis.title.y = element_textbox( + orientation = "left-rotated", face = "bold", + margin = margin(0, 0, 5, 0, "pt") + ), + axis.text.y = element_text(hjust = 1), + legend.position = "bottom", + legend.box = "vertical", + legend.text = element_text(size = 10) + )) ``` ### Getting the data -The first piece of data I'll use comes from the Amsterdam Real Estate Association. They publish quarterly data on a number of variables about the Amsterdam housing market ([link](https://www.mva.nl/over-de-mva/mva/kwartaalcijfers)), inclusing asking price, final price paid, number of properties put on the market, number of properties sold and a few more back to the first quarter of 2012. _Obviously_, these numbers all come in pdf-format, because the people writing quarterly reports apparently have a _massive hatred_ towards people that want to analyze this data. I downloaded the reports, used the online tool [PDFTables](https://pdftables.com) to convert them to Excel, and then stitched the tables together manually. Of course (remember the authors have a _massive hatred_ towards us), the formatting of the numbers in the tables weren't consistent between different quarterly reports, so I had to do some cleaning in R. I put each table in a separate sheet and then used functionality from the `{readxl}` package to load each table into a different variable and then do the cleaning per table. This was a bit cumbersome. Since this will probably be a very long post, I'll hide the code, but you can see it in the [Rmarkdown file](https://github.com/danielroelfs/danielroelfs.com/blob/main/content/blog/2020-running-an-ica-on-questionnaires/index.Rmd) (at least until I figure out how to get code folding to work on my laptop). +{{{< sidenote br="10em" >}}} +There are [R packages](https://docs.ropensci.org/tabulizer/) that can parse PDF files, but in my experience they can be clunky. In this case the simplest solution seemed the best, despite requiring some manual work +{{{< /sidenote >}}} + +The first piece of data I'll use comes from the Amsterdam Real Estate Association. They publish quarterly data on a number of variables about the Amsterdam housing market ([link](https://www.mva.nl/over-de-mva/mva/kwartaalcijfers)), inclusing asking price, final price paid, number of properties put on the market, number of properties sold and a few more back to the first quarter of 2012. _Obviously_, these numbers all come in pdf-format, because the people writing quarterly reports apparently have a _massive hatred_ towards people that want to analyze this data. I downloaded the reports, used the online tool [PDFTables](https://pdftables.com) to convert them to Excel, and then stitched the tables together manually. Of course (remember the authors have a _massive hatred_ towards us), the formatting of the numbers in the tables weren't consistent between different quarterly reports, so I had to do some cleaning in R. I put each table in a separate sheet and then used functionality from the `{readxl}` package to load each table into a different variable and then do the cleaning per table. This was a bit cumbersome. You can look at the code I used to load and merge the files. It's a bit of a mess: @@ -92,61 +119,135 @@ You can look at the code I used to load and merge the files. It's a bit of a mes #| code-fold: true #| code-summary: "Show code" -asking_price <- readxl::read_xlsx("MVA_kwartaalcijfers.xlsx", sheet = 2) |> - janitor::clean_names() |> - mutate(type_woning = as_factor(type_woning), - across(where(is.double), ~ .x * 1e3), - across(where(is.character), ~ parse_number(str_remove_all(.x, fixed(" "))))) |> - pivot_longer(starts_with("x"), names_to = "date", values_to = "asking_price") - -transaction_price <- readxl::read_xlsx("MVA_kwartaalcijfers.xlsx", sheet = 3) |> - janitor::clean_names() |> - mutate(type_woning = as_factor(type_woning), - across(where(is.character), ~ parse_number(str_remove_all(.x, fixed(" "))))) |> - pivot_longer(starts_with("x"), names_to = "date", values_to = "transaction_price") - -price_per_m2 <- readxl::read_xlsx("MVA_kwartaalcijfers.xlsx", sheet = 4) |> - janitor::clean_names() |> - mutate(type_woning = as_factor(type_woning), - across(where(is.double), ~ .x * 1e3), - across(where(is.character), ~ parse_number(str_remove_all(.x, fixed(" "))))) |> - pivot_longer(starts_with("x"), names_to = "date", values_to = "price_per_m2") - -n_offered <- readxl::read_xlsx("MVA_kwartaalcijfers.xlsx", sheet = 5) |> - janitor::clean_names() |> - mutate(type_woning = as_factor(type_woning), - across(where(is.character), ~ parse_number(str_remove_all(.x, fixed(" "))))) |> - pivot_longer(starts_with("x"), names_to = "date", values_to = "n_offered") - -n_sold <- readxl::read_xlsx("MVA_kwartaalcijfers.xlsx", sheet = 6) |> - janitor::clean_names() |> - mutate(type_woning = as_factor(type_woning), - across(where(is.character), ~ parse_number(str_remove_all(.x, fixed(" "))))) |> - pivot_longer(starts_with("x"), names_to = "date", values_to = "n_sold") - -mortgage_months <- readxl::read_xlsx("MVA_kwartaalcijfers.xlsx", sheet = 7) |> - janitor::clean_names() |> - mutate(type_woning = as_factor(type_woning), - across(where(is.character), ~ parse_number(str_remove_all(.x, fixed(" "))))) |> - pivot_longer(starts_with("x"), names_to = "date", values_to = "mortgage_months") - -tightness_index <- readxl::read_xlsx("MVA_kwartaalcijfers.xlsx", sheet = 8) |> - janitor::clean_names() |> - mutate(type_woning = as_factor(type_woning), - across(where(is.character), ~ parse_number(str_replace_all(.x, ",", ".")))) |> - pivot_longer(starts_with("x"), names_to = "date", values_to = "tightness_index") - -data_merged <- inner_join(asking_price, transaction_price) |> - inner_join(price_per_m2) |> - inner_join(n_offered) |> - inner_join(n_sold) |> - inner_join(mortgage_months) |> - inner_join(tightness_index) |> - mutate(asking_price = ifelse(asking_price < 1e5, asking_price * 1e3, asking_price), - transaction_price = ifelse(transaction_price < 1e5, transaction_price * 1e3, transaction_price), - price_per_m2 = ifelse(price_per_m2 > 1e4, price_per_m2 / 1e3, price_per_m2)) - -write_rds(data_merged, "data_merged.rds") +asking_price <- readxl::read_xlsx("./data/MVA_kwartaalcijfers.xlsx", + sheet = 2 +) |> + janitor::clean_names() |> + mutate( + type_woning = as_factor(type_woning), + across(where(is.double), ~ .x * 1e3), + across( + where(is.character), + ~ parse_number(str_remove_all(.x, fixed(" "))) + ) + ) |> + pivot_longer(starts_with("x"), + names_to = "date", values_to = "asking_price" + ) + +transaction_price <- readxl::read_xlsx("./data/MVA_kwartaalcijfers.xlsx", + sheet = 3 +) |> + janitor::clean_names() |> + mutate( + type_woning = as_factor(type_woning), + across( + where(is.character), + ~ parse_number(str_remove_all(.x, fixed(" "))) + ) + ) |> + pivot_longer(starts_with("x"), + names_to = "date", values_to = "transaction_price" + ) + +price_per_m2 <- readxl::read_xlsx("./data/MVA_kwartaalcijfers.xlsx", + sheet = 4 +) |> + janitor::clean_names() |> + mutate( + type_woning = as_factor(type_woning), + across(where(is.double), ~ .x * 1e3), + across( + where(is.character), + ~ parse_number(str_remove_all(.x, fixed(" "))) + ) + ) |> + pivot_longer(starts_with("x"), + names_to = "date", values_to = "price_per_m2" + ) + +n_offered <- readxl::read_xlsx("./data/MVA_kwartaalcijfers.xlsx", + sheet = 5 +) |> + janitor::clean_names() |> + mutate( + type_woning = as_factor(type_woning), + across( + where(is.character), + ~ parse_number(str_remove_all(.x, fixed(" "))) + ) + ) |> + pivot_longer(starts_with("x"), + names_to = "date", values_to = "n_offered" + ) + +n_sold <- readxl::read_xlsx("./data/MVA_kwartaalcijfers.xlsx", + sheet = 6 +) |> + janitor::clean_names() |> + mutate( + type_woning = as_factor(type_woning), + across( + where(is.character), + ~ parse_number(str_remove_all(.x, fixed(" "))) + ) + ) |> + pivot_longer(starts_with("x"), + names_to = "date", values_to = "n_sold" + ) + +mortgage_months <- readxl::read_xlsx("./data/MVA_kwartaalcijfers.xlsx", + sheet = 7 +) |> + janitor::clean_names() |> + mutate( + type_woning = as_factor(type_woning), + across( + where(is.character), + ~ parse_number(str_remove_all(.x, fixed(" "))) + ) + ) |> + pivot_longer(starts_with("x"), + names_to = "date", values_to = "mortgage_months" + ) + +tightness_index <- readxl::read_xlsx("./data/MVA_kwartaalcijfers.xlsx", + sheet = 8 +) |> + janitor::clean_names() |> + mutate( + type_woning = as_factor(type_woning), + across( + where(is.character), + ~ parse_number(str_replace_all(.x, ",", ".")) + ) + ) |> + pivot_longer(starts_with("x"), + names_to = "date", values_to = "tightness_index" + ) + +data_merged <- inner_join(asking_price, transaction_price) |> + inner_join(price_per_m2) |> + inner_join(n_offered) |> + inner_join(n_sold) |> + inner_join(mortgage_months) |> + inner_join(tightness_index) |> + mutate( + asking_price = ifelse(asking_price < 1e5, + asking_price * 1e3, + asking_price + ), + transaction_price = ifelse(transaction_price < 1e5, + transaction_price * 1e3, + transaction_price + ), + price_per_m2 = ifelse(price_per_m2 > 1e4, + price_per_m2 / 1e3, + price_per_m2 + ) + ) + +write_rds(data_merged, "./data/data_merged.rds") ``` Let's have a look at the dataset. @@ -156,7 +257,7 @@ Let's have a look at the dataset. #| code-fold: true #| code-summary: "Show code" -data_merged <- read_rds("data_merged.rds") +data_merged <- read_rds("./data/data_merged.rds") glimpse(data_merged) ``` @@ -168,32 +269,42 @@ From this dataset, I want to create a few new variables. I want to create a date #| code-fold: true #| code-summary: "Show code" -data <- data_merged |> - rename(type = type_woning) |> - mutate(quarter = str_extract(date, pattern = "x(.*?)e"), - quarter = parse_number(quarter), - year = str_extract(date, pattern = "kw_(.*)"), - year = parse_number(year), - date = as.Date(str_glue("{year}-{(quarter * 3)}-01")), - diff_ask_paid = transaction_price - asking_price, - diff_ask_paid_perc = diff_ask_paid / asking_price, - diff_offered_sold = n_offered - n_sold, - diff_offered_sold_perc = diff_offered_sold / n_offered, - perc_sold = n_sold / n_offered, - type = case_when(str_detect(type,"Totaal") ~ "Total", - str_detect(type,"<= 1970") ~ "Apartments (pre-1970)", - str_detect(type,"> 1970") ~ "Apartments (post-1970)", - str_detect(type,"Tussenwoning") ~ "Terraced house", - str_detect(type,"Hoekwoning") ~ "Corner house", - str_detect(type,"Vrijstaand") ~ "Detached house", - str_detect(type,"2-onder-1-kap") ~ "Semi-detached house"), - type = factor(type, levels = c("Apartments (pre-1970)","Apartments (post-1970)", - "Terraced house","Corner house","Detached house", - "Semi-detached house","Total"))) |> +data <- data_merged |> + rename(type = type_woning) |> + mutate( + quarter = str_extract(date, pattern = "x(.*?)e"), + quarter = parse_number(quarter), + year = str_extract(date, pattern = "kw_(.*)"), + year = parse_number(year), + date = as.Date(str_glue("{year}-{(quarter * 3)}-01")), + diff_ask_paid = transaction_price - asking_price, + diff_ask_paid_perc = diff_ask_paid / asking_price, + diff_offered_sold = n_offered - n_sold, + diff_offered_sold_perc = diff_offered_sold / n_offered, + perc_sold = n_sold / n_offered, + type = case_when( + str_detect(type, "Totaal") ~ "Total", + str_detect(type, "<= 1970") ~ "Apartments (pre-1970)", + str_detect(type, "> 1970") ~ "Apartments (post-1970)", + str_detect(type, "Tussenwoning") ~ "Terraced house", + str_detect(type, "Hoekwoning") ~ "Corner house", + str_detect(type, "Vrijstaand") ~ "Detached house", + str_detect(type, "2-onder-1-kap") ~ "Semi-detached house" + ), + type = factor(type, levels = c( + "Apartments (pre-1970)", "Apartments (post-1970)", + "Terraced house", "Corner house", "Detached house", + "Semi-detached house", "Total" + )) + ) |> glimpse() ``` -The first thing that seems interesting to do is to plot the percentage difference between the asking price and the price paid. This will give us an indication of the trend in overpaying on different types of properties. I'll use a color palette and legend design I again shamelessly stole from Cédric Scherer ([@CedScherer](https://twitter.com/CedScherer)). I'll use a simple line graph to visualize the percentage overpay. +{{{< sidenote br="1em" >}}} +I'll use a color palette and legend design I shamelessly stole from [Cédric Scherer](https://twitter.com/CedScherer) +{{{< /sidenote >}}} + +The first thing that seems interesting to do is to plot the percentage difference between the asking price and the price paid. This will give us an indication of the trend in overpaying on different types of properties. Let's use a simple line graph to visualize the percentage overpay. ```{r} #| label: plot-overpay @@ -201,33 +312,48 @@ The first thing that seems interesting to do is to plot the percentage differenc #| code-fold: true #| code-summary: "Show code" -colors <- c("#019868","#9dd292","#ec0b88","#651eac","#e18a1e","#2b7de5") - -data |> - filter(type != "Total") |> - group_by(type) |> - mutate(n_total = sum(n_sold), - type_label = str_glue("{type} (n={format(n_total, big.mark = \".\", decimal.mark = \",\")})"), - type_label = str_replace(type_label,"\\) \\(", ", ")) |> - arrange(type) |> - mutate(type_label = factor(type_label)) |> - ggplot(aes(x = date, y = diff_ask_paid_perc, color = type_label)) + +colors <- c("#019868", "#9dd292", "#ec0b88", "#651eac", "#e18a1e", "#2b7de5") + +data |> + filter(type != "Total") |> + group_by(type) |> + mutate( + n_total = sum(n_sold), + type_label = str_glue( + "{type} (n={format(n_total, big.mark = \".\", decimal.mark = \",\")})" + ), + type_label = str_replace(type_label, "\\) \\(", ", ") + ) |> + arrange(type) |> + mutate(type_label = factor(type_label)) |> + ggplot(aes(x = date, y = diff_ask_paid_perc, color = type_label)) + geom_hline(yintercept = 0, color = "grey30", size = 1) + - geom_line(size = 1.2, alpha = 0.8, lineend = "round", key_glyph = "point") + - labs(title = "Overbidding has become the new normal", - subtitle = "_Paying as much as 5% over asking price is common the past few years_", - x = NULL, - y = "Percentage difference between\nasking price and price paid", - color = NULL, - caption = "_**Data**: MVA_") + - scale_y_continuous(labels = scales::label_percent()) + - scale_color_manual(values = colors, - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(fill = "transparent", size = 6, alpha = 1))) + - theme(plot.title = element_textbox(size = 20), - axis.title.y = element_textbox(width = grid::unit(2.5, "in")), - legend.key = element_rect(fill = "transparent", color = "transparent")) + geom_line( + size = 1.2, alpha = 0.8, + lineend = "round", key_glyph = "point" + ) + + labs( + title = "Overbidding has become the new normal", + subtitle = "_Paying as much as 5% over asking price is common the past few years_", + x = NULL, + y = "Percentage difference between\nasking price and price paid", + color = NULL, + caption = "_**Data**: MVA_" + ) + + scale_y_continuous(labels = scales::label_percent()) + + scale_color_manual( + values = colors, + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list(fill = "transparent", size = 6, alpha = 1) + ) + ) + + theme( + plot.title = element_textbox(size = 20), + axis.title.y = element_textbox(width = grid::unit(2.5, "in")), + legend.key = element_rect(fill = "transparent", color = "transparent") + ) ``` Prior to 2014, most properties in Amsterdam were sold at about 6% below asking price, in the last quarter of 2020, that trend had changed to more than 3.5% above asking. The variance is obviously larger for detached and semi-detached houses, since those are both expensive and scarce in Amsterdam, and are thus also bought and sold less often. The table below shows the stats for the first quarter of 2021. Apart from semi-detached houses, most other properties were sold at 4% over asking or more. The types of properties most accessible to first-time buyers are obviously the apartments. Either the older type in the inner city, or the newer apartments in the suburbs. People buying pre-1970 apartments spent more than €28 000 over the asking price and people buying apartments built after 1970 spent on average more than €18 000 over the asking price. @@ -238,27 +364,40 @@ Prior to 2014, most properties in Amsterdam were sold at about 6% below asking p #| code-fold: true #| code-summary: "Show code" -data |> - filter(type != "Total", - date == max(date)) |> - select(type, diff_ask_paid_perc, diff_ask_paid, transaction_price, n_sold) |> - arrange(-diff_ask_paid_perc) |> - gt() |> - cols_align(columns = "type", align = "left") |> - fmt_percent(columns = "diff_ask_paid_perc") |> - fmt_currency(columns = "diff_ask_paid", currency = "EUR", decimals = 0, sep_mark = " ") |> - fmt_currency(columns = "transaction_price", currency = "EUR", decimals = 0, sep_mark = " ") |> - fmt_number(columns = "n_sold", sep_mark = " ", drop_trailing_zeros = TRUE) |> +data |> + filter( + type != "Total", + date == max(date) + ) |> + select(type, diff_ask_paid_perc, diff_ask_paid, transaction_price, n_sold) |> + arrange(-diff_ask_paid_perc) |> + gt() |> + cols_align(columns = "type", align = "left") |> + fmt_percent(columns = "diff_ask_paid_perc") |> + fmt_currency( + columns = "diff_ask_paid", currency = "EUR", + decimals = 0, sep_mark = " " + ) |> + fmt_currency( + columns = "transaction_price", currency = "EUR", + decimals = 0, sep_mark = " " + ) |> + fmt_number( + columns = "n_sold", sep_mark = " ", + drop_trailing_zeros = TRUE + ) |> cols_label( type = html("Property type
"), diff_ask_paid_perc = html("Percentage overpay
"), diff_ask_paid = html("Mean overpay
"), transaction_price = html("Mean transaction price
"), n_sold = html("Number of properties
sold in period
")
- ) |>
- tab_header(title = html("Difference between
asking price and price paid
"),
- subtitle = html("Data from the first quarter of 2021
")) |> - tab_source_note(source_note = md("_**Data**: MVA_")) |> + ) |> + tab_header( + title = html("Difference between
asking price and price paid
"),
+ subtitle = html("Data from the first quarter of 2021
") + ) |> + tab_source_note(source_note = md("_**Data**: MVA_")) |> tab_options(table.background.color = "#EBEBEB") |> gtsave("overpay-table.png", expand = 0) ``` @@ -273,47 +412,76 @@ What contributed to this price increase? A simple supply-and-demand plays a part #| code-fold: true #| code-summary: "Show code" -data |> - filter(type != "Total") |> - group_by(type) |> - mutate(n_total = sum(n_sold), - type_label = str_glue("{type} (n={format(n_total, big.mark = \".\", decimal.mark = \",\")})"), - type_label = str_replace(type_label,"\\) \\(", ", ")) |> - arrange(type) |> - mutate(type_label = factor(type_label)) |> - ggplot(aes(x = date, y = tightness_index, color = type_label)) + - geom_rect(data = tibble(), - aes(xmin = as.Date(-Inf), xmax = as.Date(Inf), ymin = c(0,5,10), ymax = c(5,10,Inf), - fill = c("Sellers market", "Balanced market", "Buyers market")), - color = "transparent", alpha = 0.2, key_glyph = "point", inherit.aes = FALSE) + +data |> + filter(type != "Total") |> + group_by(type) |> + mutate( + n_total = sum(n_sold), + type_label = str_glue( + "{type} (n={format(n_total, big.mark = \".\", decimal.mark = \",\")})" + ), + type_label = str_replace(type_label, "\\) \\(", ", ") + ) |> + arrange(type) |> + mutate(type_label = factor(type_label)) |> + ggplot(aes(x = date, y = tightness_index, color = type_label)) + + geom_rect( + data = tibble(), + aes( + xmin = as.Date(-Inf), xmax = as.Date(Inf), + ymin = c(0, 5, 10), ymax = c(5, 10, Inf), + fill = c("Sellers market", "Balanced market", "Buyers market") + ), + color = "transparent", alpha = 0.2, key_glyph = "point", inherit.aes = FALSE + ) + geom_hline(yintercept = 0, color = "grey30", size = 1) + - geom_line(size = 1.2, alpha = 0.8, lineend = "round", key_glyph = "point") + - labs(title = "Amsterdam has had a sellers market for nearly 5 years", - x = NULL, - y = "Indicator of _\"density\"_ on the housing market", - color = NULL, - fill = "Type of market:", - caption = "_**Data**: MVA_") + - scale_x_date(expand = c(0,0)) + - scale_y_continuous(trans = "reverse", expand = c(0,0)) + - scale_color_manual(values = colors, - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", order = 1, - override.aes = list(fill = "transparent", size = 6, alpha = 1))) + - scale_fill_manual(values = c("#F5E000","#00B300","#D1000E"), - limits = c("Buyers market","Balanced market","Sellers market"), - guide = guide_legend(order = 2, override.aes = list(shape = 21, size = 6, alpha = 1, stroke = 0))) + + geom_line(size = 1.2, alpha = 0.8, lineend = "round", key_glyph = "point") + + labs( + title = "Amsterdam has had a sellers market for nearly 5 years", + x = NULL, + y = "Indicator of _\"density\"_ on the housing market", + color = NULL, + fill = "Type of market:", + caption = "_**Data**: MVA_" + ) + + scale_x_date(expand = c(0, 0)) + + scale_y_continuous(trans = "reverse", expand = c(0, 0)) + + scale_color_manual( + values = colors, + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", order = 1, + override.aes = list(fill = "transparent", size = 6, alpha = 1) + ) + ) + + scale_fill_manual( + values = c("#F5E000", "#00B300", "#D1000E"), + limits = c("Buyers market", "Balanced market", "Sellers market"), + guide = guide_legend( + order = 2, + override.aes = list( + shape = 21, size = 6, + alpha = 1, stroke = 0 + ) + ) + ) + coord_cartesian(clip = "off") + - theme(plot.title = element_textbox(size = 16), - plot.subtitle = element_textbox(size = 10), - axis.title.y = element_textbox(orientation = "left-rotated", - width = grid::unit(2, "in")), - legend.key = element_rect(fill = "transparent")) + theme( + plot.title = element_textbox(size = 16), + plot.subtitle = element_textbox(size = 10), + axis.title.y = element_textbox( + orientation = "left-rotated", + width = grid::unit(2, "in") + ), + legend.key = element_rect(fill = "transparent") + ) ``` So, there's a lot of competition among buyers, and people looking to sell their houses can expect to be paid more than they anticipated. Dozens of buyers compete for the same properties, driving up the price. The figure below shows the percentage of properties sold compared to the number of properties offered. It's clear that after the 2008 housing bubble crisis, the housing market was still recovering in 2012 and 2013. However, since 2016, more apartments were sold than were put on the market. This means that the number of properties available for the growing number of people wanting to move to Amsterdam is decreasing. This decreases supply in a time with increasing demand, thus pushing the prices higher twice over. -A new phenomenon that entered the scene a little while ago may indicate how skewed the market is. People wanting to buy a house in a certain neighborhood will put notes and letters in the mailboxes of people living in that area saying "Nice house! Are you interested in selling it to me?". This is now not an uncommon strategy to find a house. Some people living in popular neighborshoods are inundated with notes from agencies facilitating these practices. See also a news item by RTL.
+{{{< standout bg="#acc8d4" >}}} +A new phenomenon that entered the scene a little while ago may indicate how skewed the market is. People wanting to buy a house in a certain neighborhood will put notes and letters in the mailboxes of people living in that area saying _"Nice house! Are you interested in selling it to me?"_. This is now not an uncommon strategy to find a house. Some people living in popular neighborshoods are inundated with notes from agencies facilitating these practices. See also a [news item by RTL](https://www.rtlnieuws.nl/geld-en-werk/artikel/19001/droomhuis-gezien-maar-niet-te-koop-stop-dan-een-briefje-de-bus) +{{{< /standout >}}} ```{r} #| label: plot-n-sales @@ -323,29 +491,45 @@ So, there's a lot of competition among buyers, and people looking to sell their #| code-fold: true #| code-summary: "Show code" -data |> - filter(type != "Total") |> - ggplot(aes(x = date, y = perc_sold, fill = type)) + - geom_col(key_glyph = "point") + +data |> + filter(type != "Total") |> + ggplot(aes(x = date, y = perc_sold, fill = type)) + + geom_col(key_glyph = "point") + geom_hline(yintercept = 1, linetype = "dashed", color = "grey20") + - labs(title = "Some years, more houses are sold than are being put on the market", - x = NULL, - y = "Percentage of offered houses sold", - fill = NULL, - caption = "_**Data**: MVA_") + + labs( + title = "Some years, more houses are sold than are being put on the market", + x = NULL, + y = "Percentage of offered houses sold", + fill = NULL, + caption = "_**Data**: MVA_" + ) + coord_cartesian(clip = "off") + - scale_y_continuous(labels = scales::label_percent(), expand = c(0,NA), n.breaks = 4) + - scale_fill_manual(values = colors, - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(shape = 21, size = 6, alpha = 1, stroke = 0))) + - theme(plot.title = element_textbox(size = 20, - width = grid::unit(6,"in")), - plot.subtitle = element_textbox(size = 10), - strip.text.x = element_markdown(face = "bold", padding = margin(10,0,5,0,"pt")), - strip.background = element_rect(fill = "transparent"), - legend.key = element_rect(fill = "transparent")) + - facet_wrap(~ type, strip.position = "top", scales = "free_x") + scale_y_continuous( + labels = scales::label_percent(), + expand = c(0, NA), n.breaks = 4 + ) + + scale_fill_manual( + values = colors, + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list(shape = 21, size = 6, alpha = 1, stroke = 0) + ) + ) + + theme( + plot.title = element_textbox( + size = 20, + width = grid::unit(6, "in") + ), + plot.subtitle = element_textbox(size = 10), + strip.text.x = element_markdown( + face = "bold", + padding = margin(10, 0, 5, 0, "pt") + ), + strip.background = element_rect(fill = "transparent"), + legend.key = element_rect(fill = "transparent") + ) + + facet_wrap(~type, strip.position = "top", scales = "free_x") ``` This adds fuel to the fire. I guess I'm trying to show that there are a number of factors stacked against young buyers. Any money you have saved up you need to spend to outbid the massive competition. The massive competition means buyers only have a handful of feasible options. Again, because of the massive competition, the chance they actually get to buy one of those options is low. The number of options is not steady either, the number properties sold has overtaken the number of properties being put on the market. There is a dwindling reserve of properties. Combine this with more and more young people wanting to move to the bigger cities and you have a perfect cocktail for a congested housing market. Building new properties can counteract this, but over the last years the Netherlands has actually slowed building new properties. @@ -360,55 +544,88 @@ This adds fuel to the fire. I guess I'm trying to show that there are a number o #| code-summary: "Show code" decades <- tibble( - x1 = seq(1920,2020,10), + x1 = seq(1920, 2020, 10), x2 = x1 + 10 -) |> - slice(seq(1,1e2,2)) |> +) |> + slice(seq(1, 1e2, 2)) |> filter(x2 < 2030) -hist_data_homes <- cbsodataR::cbs_get_data("82235NED") |> - janitor::clean_names() |> - rename(stock_end = eindstand_voorraad_8) |> - mutate(year = parse_number(perioden), - stock_end = stock_end * 1e3, - diff = stock_end - lag(stock_end)) +hist_data_homes <- cbsodataR::cbs_get_data("82235NED") |> + janitor::clean_names() |> + rename(stock_end = eindstand_voorraad_8) |> + mutate( + year = parse_number(perioden), + stock_end = stock_end * 1e3, + diff = stock_end - lag(stock_end) + ) -total_hist_plot <- hist_data_homes |> +total_hist_plot <- hist_data_homes |> ggplot(aes(x = year, y = stock_end)) + - geom_rect(data = tibble(), aes(xmin = 1940.01, xmax = 1945, ymin = -Inf, ymax = Inf), - fill = "red", alpha = 0.2, inherit.aes = FALSE) + - geom_text(data = tibble(), aes(x = 1942.5, y = max(hist_data_homes$stock_end, na.rm = TRUE), vjust = 0, label = "WWII"), size = 3, - fontface = "bold", family = "nunito-sans", inherit.aes = FALSE) + - geom_rect(data = decades, aes(xmin = x1, xmax = x2, ymin = -Inf, ymax = Inf), - fill = "grey30", alpha = 0.2, color = "transparent", inherit.aes = FALSE) + + geom_rect( + data = tibble(), aes(xmin = 1940.01, xmax = 1945, ymin = -Inf, ymax = Inf), + fill = "red", alpha = 0.2, inherit.aes = FALSE + ) + + geom_text( + data = tibble(), + aes(x = 1942.5, y = max(hist_data_homes$stock_end, na.rm = TRUE)), + label = "WWII", fontface = "bold", family = "nunito-sans", + vjust = 0, size = 3, inherit.aes = FALSE + ) + + geom_rect( + data = decades, aes(xmin = x1, xmax = x2, ymin = -Inf, ymax = Inf), + fill = "grey30", alpha = 0.2, color = "transparent", inherit.aes = FALSE + ) + geom_line(color = "darkred", size = 1.5, lineend = "round") + - labs(x = NULL, - y = "Total number of homes") + - scale_x_continuous(expand = c(0,0), breaks = c(decades$x1,decades$x2,2020)) + + labs( + x = NULL, + y = "Total number of homes" + ) + + scale_x_continuous( + expand = c(0, 0), + breaks = c(decades$x1, decades$x2, 2020) + ) + scale_y_continuous(labels = scales::label_number()) + coord_cartesian(clip = "off") -diff_hist_plot <- hist_data_homes |> +diff_hist_plot <- hist_data_homes |> ggplot(aes(x = year, y = diff)) + geom_hline(yintercept = 0.5, color = "grey30", size = 1) + - geom_rect(data = tibble(), aes(xmin = 1940.01, xmax = 1945, ymin = -Inf, ymax = Inf), - fill = "red", alpha = 0.2, inherit.aes = FALSE) + - geom_text(data = tibble(), aes(x = 1942.5, y = max(hist_data_homes$diff, na.rm = TRUE), vjust = 0, label = "WWII"), size = 3, - fontface = "bold", family = "nunito-sans", inherit.aes = FALSE) + - geom_rect(data = decades, aes(xmin = x1, xmax = x2, ymin = -Inf, ymax = Inf), - fill = "grey30", alpha = 0.2, color = "transparent", inherit.aes = FALSE) + + geom_rect( + data = tibble(), aes(xmin = 1940.01, xmax = 1945, ymin = -Inf, ymax = Inf), + fill = "red", alpha = 0.2, inherit.aes = FALSE + ) + + geom_text( + data = tibble(), aes( + x = 1942.5, + y = max(hist_data_homes$diff, na.rm = TRUE), + vjust = 0, label = "WWII" + ), + size = 3, fontface = "bold", + family = "nunito-sans", inherit.aes = FALSE + ) + + geom_rect( + data = decades, aes(xmin = x1, xmax = x2, ymin = -Inf, ymax = Inf), + fill = "grey30", alpha = 0.2, color = "transparent", inherit.aes = FALSE + ) + geom_line(color = "grey30", alpha = 0.5, size = 1.5, lineend = "round") + geom_smooth(color = "darkred", size = 1.5, se = FALSE) + - labs(x = NULL, - y = "Net homes added per year") + - scale_x_continuous(expand = c(0,0), breaks = c(decades$x1,decades$x2,2020)) + + labs( + x = NULL, + y = "Net homes added per year" + ) + + scale_x_continuous( + expand = c(0, 0), + breaks = c(decades$x1, decades$x2, 2020) + ) + scale_y_continuous(labels = scales::label_number_auto()) + coord_cartesian(clip = "off") total_hist_plot / diff_hist_plot + - plot_annotation(title = "Number of houses available", - subtitle = "Data covers development in the Netherlands nationwide", - caption = "**Data**: CBS") & + plot_annotation( + title = "Number of houses available", + subtitle = "Data covers development in the Netherlands nationwide", + caption = "**Data**: CBS" + ) & theme(plot.title = element_textbox(size = 20)) ``` @@ -417,6 +634,10 @@ The figure displays data from from the CBS through the `{cbsodataR}` package. It It's also important to mention that between the 60s and 70s, the Netherlands started building entire cities from scratch on newly-reclaimed land from the sea. The province of [Flevoland](https://en.wikipedia.org/wiki/Flevoland) is currently home to about 415 000 people, and until the early 50s this province was non-existent, the current land was at the bottom of a bay of the North sea (called the Zuiderzee or "Southern Sea" in English). Other than a general enthusiasm for building, I think this contributed considerably to the increase in the number of homes added in the 60s and 70s. This new province has good access to Amsterdam, and if it weren't for this new piece of land, the shortage might have peaked earlier. +{{{< sidenote >}}} +There's actually quite a few more, but I'll focus on the ones I can quantify at the moment +{{{< /sidenote >}}} + But that's not all, there's a few other features that contribute to the gridlock. See, not only young people are on the market to buy apartments in Amsterdam. There's a thriving market for investors looking to take advantage of the rising prices in the Amsterdam housing market (source: [Algemeen Dagblad](https://www.ad.nl/wonen/beleggers-verwerven-massaal-koophuizen-voor-verhuur-in-amsterdam~afedc50c6/)). According to the Dutch central bank, about 1 in 5 properties are sold to investors, who are mostly looking to convert it to a rental property or flip it for a profit. I couldn't find the data the Dutch central bank relied on, but I found something else. The Central Bureau for Statistics collects data on the number of "mutations" among properties. The "mutation" in this case refers to the change of purpose of a property, e.g. if a house meant for sale is bought and then transformed to a rental property by either private individuals or corporations, or vice versa. I collected this data from the governmental yearly report on the housing market of 2020 ("_Staat van de Woningmarkt - Jaarrapportage 2020_", [link](https://www.rijksoverheid.nl/documenten/rapporten/2020/06/15/staat-van-de-woningmarkt-jaarrapportage-2020)). Instead of per quarter, this data is reported per year. Unfortunately, the data on housing mutations in the report (from 2020 mind you) only goes until 2017. It's important to note that these numbers are country-wide, not specific for Amsterdam. That means there could be some other factors in play. Many of these trends are present across the country, but they're massively amplified in the larger cities. The data was contained in a pdf that wasn't easily machine-readable, so I had to manually copy the numbers into a tibble, which was great... ```{r} @@ -425,7 +646,8 @@ But that's not all, there's a few other features that contribute to the gridlock #| code-summary: "Show code" house_mutations_in <- tribble( - ~year, ~buy_to_rent_corp, ~buy_to_rent_other, ~rent_corp_to_buy, ~rent_corp_to_rent_other, ~rent_other_to_buy, ~rent_other_to_rent_corp, + ~year, ~buy_to_rent_corp, ~buy_to_rent_other, ~rent_corp_to_buy, + ~rent_corp_to_rent_other, ~rent_other_to_buy, ~rent_other_to_rent_corp, 2012, 900, 58000, 14600, 5500, 50600, 4900, 2013, 800, 62200, 15200, 11500, 50900, 6000, 2014, 1000, 62200, 15400, 9300, 59900, 39000, @@ -434,19 +656,28 @@ house_mutations_in <- tribble( 2017, 1600, 98900, 6400, 11000, 7300, 9000 ) -house_mutations <- house_mutations_in |> - pivot_longer(cols = -year, names_to = "mutation", values_to = "n_mutations") |> - mutate(from = str_extract(mutation, "(.*?)_to"), - from = str_remove_all(from, "_to"), - to = str_extract(mutation, "to_(.*?)$"), - to = str_remove_all(to, "to_")) |> - group_by(year) |> - mutate(total_mutations = sum(n_mutations), - perc_mutations = n_mutations / total_mutations, - across(c(from,to), ~ case_when(str_detect(.x,"buy") ~ "buy", - str_detect(.x,"rent_corp") ~ "rent (corporation)", - str_detect(.x,"rent_other") ~ "rent (other)")), - mutation_label = str_glue("From {from} to {to}")) |> +house_mutations <- house_mutations_in |> + pivot_longer( + cols = -year, + names_to = "mutation", values_to = "n_mutations" + ) |> + mutate( + from = str_extract(mutation, "(.*?)_to"), + from = str_remove_all(from, "_to"), + to = str_extract(mutation, "to_(.*?)$"), + to = str_remove_all(to, "to_") + ) |> + group_by(year) |> + mutate( + total_mutations = sum(n_mutations), + perc_mutations = n_mutations / total_mutations, + across(c(from, to), ~ case_when( + str_detect(.x, "buy") ~ "buy", + str_detect(.x, "rent_corp") ~ "rent (corporation)", + str_detect(.x, "rent_other") ~ "rent (other)" + )), + mutation_label = str_glue("From {from} to {to}") + ) |> ungroup() ``` @@ -460,46 +691,77 @@ So not every year there's the same number of "mutations" (transformations of pur #| code-fold: true #| code-summary: "Show code" -mutations_n_plot <- house_mutations |> - arrange(from,to) |> - mutate(mutation_label = fct_inorder(mutation_label)) |> - ggplot(aes(x = year, y = n_mutations, alluvium = mutation_label, fill = mutation_label)) + +mutations_n_plot <- house_mutations |> + arrange(from, to) |> + mutate(mutation_label = fct_inorder(mutation_label)) |> + ggplot(aes( + x = year, y = n_mutations, + alluvium = mutation_label, fill = mutation_label + )) + geom_point(shape = 21, color = "transparent", size = NA) + ggalluvial::geom_flow(width = 0, show.legend = FALSE) + - labs(x = NULL, - y = "Number of mutations", - fill = NULL) + - scale_x_continuous(expand = c(0,0)) + - scale_y_continuous(labels = scales::label_number_auto(), expand = c(0,0)) + - scale_fill_manual(values = rev(colors), - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(color = "transparent", size = 6, alpha = 1, stroke = 0))) + + labs( + x = NULL, + y = "Number of mutations", + fill = NULL + ) + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous( + labels = scales::label_number_auto(), + expand = c(0, 0) + ) + + scale_fill_manual( + values = rev(colors), + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list( + color = "transparent", size = 6, + alpha = 1, stroke = 0 + ) + ) + ) + theme(legend.key = element_rect(fill = "transparent")) -mutations_perc_plot <- house_mutations |> - arrange(from,to) |> - mutate(mutation_label = fct_inorder(mutation_label)) |> - ggplot(aes(x = year, y = perc_mutations, alluvium = mutation_label, fill = mutation_label)) + +mutations_perc_plot <- house_mutations |> + arrange(from, to) |> + mutate(mutation_label = fct_inorder(mutation_label)) |> + ggplot(aes( + x = year, y = perc_mutations, + alluvium = mutation_label, fill = mutation_label + )) + geom_point(shape = 21, color = "transparent", size = NA) + ggalluvial::geom_flow(width = 0, show.legend = FALSE) + - labs(x = NULL, - y = "Percentage of total mutations per quarter", - fill = NULL) + - scale_x_continuous(expand = c(0,0)) + - scale_y_continuous(labels = scales::label_percent(), expand = c(0,0)) + - scale_fill_manual(values = rev(colors), - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(color = "transparent", size = 6, alpha = 1, stroke = 0))) + - theme(axis.title.y = element_textbox(width = grid::unit(2,"in")), - legend.key = element_rect(fill = "transparent")) + labs( + x = NULL, + y = "Percentage of total mutations per quarter", + fill = NULL + ) + + scale_x_continuous(expand = c(0, 0)) + + scale_y_continuous(labels = scales::label_percent(), expand = c(0, 0)) + + scale_fill_manual( + values = rev(colors), + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list( + color = "transparent", size = 6, + alpha = 1, stroke = 0 + ) + ) + ) + + theme( + axis.title.y = element_textbox(width = grid::unit(2, "in")), + legend.key = element_rect(fill = "transparent") + ) mutations_n_plot / mutations_perc_plot + - plot_annotation(title = "Shift to a renters market", - subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", - caption = "_**Data**: CBS_") + - plot_layout(guides = 'collect') & + plot_annotation( + title = "Shift to a renters market", + subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", + caption = "_**Data**: CBS_" + ) + + plot_layout(guides = "collect") & theme(plot.title = element_textbox(size = 20)) ``` @@ -515,53 +777,66 @@ We can look at the net number of houses added to the rental market by adding up #| code-fold: true #| code-summary: "Show code" -net_house_mutations <- house_mutations |> - mutate(across(c(from,to), ~ case_when(str_detect(.x, "rent") ~ "rent", - str_detect(.x, "buy") ~ "buy"))) |> - group_by(year) |> - filter(from != to) |> - mutate(total_mutations = sum(n_mutations)) |> - group_by(year, from, to) |> - summarise(n_mutations = sum(n_mutations), - total_mutations = first(total_mutations)) |> - pivot_wider(id_cols = c(year,total_mutations), names_from = c(from,to), values_from = n_mutations, - names_sep = "_to_") |> - mutate(net_buy_to_rent = buy_to_rent - rent_to_buy, - perc_buy_to_rent = buy_to_rent / total_mutations) - -net_mutation_plot <- net_house_mutations |> - ggplot(aes(x = year, y = net_buy_to_rent)) + +net_house_mutations <- house_mutations |> + mutate(across(c(from, to), ~ case_when( + str_detect(.x, "rent") ~ "rent", + str_detect(.x, "buy") ~ "buy" + ))) |> + group_by(year) |> + filter(from != to) |> + mutate(total_mutations = sum(n_mutations)) |> + group_by(year, from, to) |> + summarise( + n_mutations = sum(n_mutations), + total_mutations = first(total_mutations) + ) |> + pivot_wider( + id_cols = c(year, total_mutations), + names_from = c(from, to), + values_from = n_mutations, + names_sep = "_to_" + ) |> + mutate( + net_buy_to_rent = buy_to_rent - rent_to_buy, + perc_buy_to_rent = buy_to_rent / total_mutations + ) + +net_mutation_plot <- net_house_mutations |> + ggplot(aes(x = year, y = net_buy_to_rent)) + geom_hline(yintercept = 0, color = "grey30", size = 1) + - #geom_ribbon(aes(ymin = 0, ymax = net_buy_to_rent), fill = "grey30", alpha = 0.2) + geom_line(color = "darkred", size = 1.5, lineend = "round") + - #geom_textbox(data = tibble(), aes(x = 2014, y = 4e4, - # label = "Net number of properties meant for sale withdrawn from the market"), - # family = "nunito-sans", size = 4, fill = "transparent", - # maxwidth = grid::unit(2,"in"), hjust = 0.5, vjust = 0) + - #geom_curve(data = tibble(), aes(x = 2014, y = 4e4, xend = 2016.5, yend = 2.5e4), - # curvature = 0.3, size = 0.75, arrow = arrow(length = unit(2,"mm")), - # lineend = "round") + - labs(x = NULL, - y = "**Net number of properties changed from properties meant for sale to rental properties**") + - scale_y_continuous(labels = scales::label_number_auto(), limits = c(-3e4, NA), n.breaks = 5) + - theme(axis.title.y = element_textbox(width = grid::unit(3.5,"in"))) - -perc_mutation_plot <- net_house_mutations |> - ggplot(aes(x = year, y = perc_buy_to_rent)) + + labs( + x = NULL, + y = "**Net number of properties changed from properties meant for sale to rental properties**" + ) + + scale_y_continuous( + labels = scales::label_number_auto(), + limits = c(-3e4, NA), n.breaks = 5 + ) + + theme(axis.title.y = element_textbox(width = grid::unit(3.5, "in"))) + +perc_mutation_plot <- net_house_mutations |> + ggplot(aes(x = year, y = perc_buy_to_rent)) + geom_hline(yintercept = 0.5, color = "grey30", size = 1) + geom_line(color = "darkred", size = 1.5, lineend = "round") + - labs(x = NULL, - y = "**Percentage of mutations that changed properties meant for sale to rental properties**") + - scale_y_continuous(labels = scales::label_percent(), limits = c(0,1), expand = c(0,0)) + + labs( + x = NULL, + y = "**Percentage of mutations that changed properties meant for sale to rental properties**" + ) + + scale_y_continuous( + labels = scales::label_percent(), + limits = c(0, 1), expand = c(0, 0) + ) + coord_cartesian(clip = "off") + - theme(axis.title.y = element_textbox(width = grid::unit(3.5,"in"))) - -net_mutation_plot + perc_mutation_plot + - plot_annotation(title = "Major net shift towards rental market", - subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", - caption = "_**Data**: CBS_") & + theme(axis.title.y = element_textbox(width = grid::unit(3.5, "in"))) + +net_mutation_plot + perc_mutation_plot + + plot_annotation( + title = "Major net shift towards rental market", + subtitle = "_A lot more houses meant for sale are being transformed into rental properties than vice versa_", + caption = "_**Data**: CBS_" + ) & theme(plot.title = element_textbox(size = 20)) - ``` So in 2017 nearly 90 000 houses were mutated from sale to rental properties. In that same year, about 62 000 new homes were built (source: [CBS](https://www.cbs.nl/nl-nl/nieuws/2018/04/hoogste-aantal-nieuwbouwwoningen-in-acht-jaar)). Not all of those 62 000 homes are meant for sale, a proportion are added to the rental market, but even if all those new homes were meant for sale, the sale market still shrunk due to the (net) ~90 000 properties that were transformed and in that way removed from the sale market. @@ -572,36 +847,49 @@ So in 2017 nearly 90 000 houses were mutated from sale to rental properties. In #| code-fold: true #| code-summary: "Show code" -house_mutations |> - filter(year == max(year)) |> - select(from, to, n_mutations, perc_mutations) |> - mutate(across(c(from,to), ~ str_to_sentence(.x))) |> - arrange(-perc_mutations) |> - gt() |> - fmt_number(columns = "n_mutations", sep_mark = " ", drop_trailing_zeros = TRUE) |> - fmt_percent(columns = "perc_mutations") |> +house_mutations |> + filter(year == max(year)) |> + select(from, to, n_mutations, perc_mutations) |> + mutate(across(c(from, to), ~ str_to_sentence(.x))) |> + arrange(-perc_mutations) |> + gt() |> + fmt_number( + columns = "n_mutations", sep_mark = " ", + drop_trailing_zeros = TRUE + ) |> + fmt_percent(columns = "perc_mutations") |> grand_summary_rows( columns = "n_mutations", fns = list(total = "sum"), - formatter = fmt_number, + fmt = ~ fmt_number(.), sep_mark = " ", - drop_trailing_zeros = TRUE) |> + drop_trailing_zeros = TRUE + ) |> grand_summary_rows( columns = "perc_mutations", fns = list(total = "sum"), - formatter = fmt_percent, - missing_text = "") |> + fmt = ~ fmt_percent(.), + missing_text = "" + ) |> cols_label( from = html("From
"), to = html("To
"), n_mutations = html("Number of mutations
"), perc_mutations = html("Percentage of total mutations
") - ) |> - tab_header(title = html("Mutations in the Dutch housing market
"), - subtitle = html("Data from the year 2017
")) |> - tab_source_note(source_note = md("_**Data**: CBS_")) |> - tab_options(table.background.color = "#EBEBEB", - grand_summary_row.text_transform = "capitalize") |> + ) |> + tab_header( + title = html( + "Mutations in the Dutch housing market
" + ), + subtitle = html( + "Data from the year 2017
" + ) + ) |> + tab_source_note(source_note = md("_**Data**: CBS_")) |> + tab_options( + table.background.color = "#EBEBEB", + grand_summary_row.text_transform = "capitalize" + ) |> gtsave("mutations-table.png", expand = 0) ``` @@ -616,48 +904,65 @@ So what's the result of all these phenomena? The figure below shows the housing #| code-fold: true #| code-summary: "Show code" -asking_start <- data |> - filter(type != "Total", - date == min(date)) |> - rename(asking_start = asking_price) |> +asking_start <- data |> + filter( + type != "Total", + date == min(date) + ) |> + rename(asking_start = asking_price) |> select(type, asking_start) -data_asking_index <- data |> - filter(type != "Total") |> - left_join(asking_start) |> +data_asking_index <- data |> + filter(type != "Total") |> + left_join(asking_start) |> mutate(asking_index = asking_price / asking_start) -data_asking_index |> - ggplot(aes(x = date, y = asking_index, color = type, group = type)) + - geom_line(size = 2, alpha = 0.15, lineend = "round", show.legend = FALSE) + +data_asking_index |> + ggplot(aes(x = date, y = asking_index, color = type, group = type)) + + geom_line(size = 2, alpha = 0.15, lineend = "round", show.legend = FALSE) + geom_smooth(se = FALSE, show.legend = FALSE) + - geom_point(size = NA) + - labs(title = "Price development over the past decade", - subtitle = "_On average, properties doubled in value since 2012_", - x = NULL, - y = "Price development relative to early 2012", - color = NULL, - caption = "_**Data**: MVA_") + - scale_y_continuous(labels = scales::label_percent()) + - scale_color_manual(values = colors, - guide = guide_legend(title.position = "top", title.hjust = 0.5, nrow = 2, - label.position = "right", - override.aes = list(fill = "transparent", size = 6, alpha = 1))) + - theme(plot.title = element_textbox(size = 20), - axis.title.y = element_textbox(width = grid::unit(2.5, "in")), - legend.key = element_rect(fill = "transparent", color = "transparent")) - + geom_point(size = NA) + + labs( + title = "Price development over the past decade", + subtitle = "_On average, properties doubled in value since 2012_", + x = NULL, + y = "Price development relative to early 2012", + color = NULL, + caption = "_**Data**: MVA_" + ) + + scale_y_continuous(labels = scales::label_percent()) + + scale_color_manual( + values = colors, + guide = guide_legend( + title.position = "top", title.hjust = 0.5, nrow = 2, + label.position = "right", + override.aes = list(fill = "transparent", size = 6, alpha = 1) + ) + ) + + theme( + plot.title = element_textbox(size = 20), + axis.title.y = element_textbox(width = grid::unit(2.5, "in")), + legend.key = element_rect(fill = "transparent", color = "transparent") + ) ``` -Adjusted for the number of properties offered, the average asking price in Amsterdam has increased by `r data_asking_index |> filter(date == max(date)) %$% weighted.mean(asking_index, n_offered) %>% subtract(.,1) |> scales::percent()`. That means that prices since 2012 have (on average) doubled. For apartments, this increase was `r data_asking_index |> filter(str_detect(type,"Apartments"), date == max(date)) %$% weighted.mean(asking_index, n_offered) %>% subtract(.,1) |> scales::percent()`. Inflation on the other hand was only about 8.5% since 2012. So young people wanting to buy a house in Amsterdam need to bring nearly twice as much money to the table as they did just a decade ago. The money they saved and the salaries they earned have by no means kept up with the increasing price though. +{{{< sidenote >}}} +Inflation since 2012 was about 8.5% which should be subtracted from these values +{{{< /sidenote >}}} + +Adjusted for the number of properties offered, the average asking price in Amsterdam has increased by `r data_asking_index |> filter(date == max(date)) %$% weighted.mean(asking_index, n_offered) %>% subtract(.,1) |> scales::percent()`. That means that prices since 2012 have (on average) roughly doubled. For apartments, this increase was `r data_asking_index |> filter(str_detect(type,"Apartments"), date == max(date)) %$% weighted.mean(asking_index, n_offered) %>% subtract(.,1) |> scales::percent()`. So young people wanting to buy a house in Amsterdam need to bring nearly twice as much money to the table as they did just a decade ago. The money they saved and the salaries they earned have by no means kept up with the increasing price though. I cannot know this for sure, because the data I presented here doesn't contain the answer, but perhaps these factors combined play a role in the financial uncertainty that millenials experience. How do we fix it? I'm not sure. This is a really complicated issue. But a few things might (in my opinion) help: -1. **Build more (sustainable) durable houses** -1. **Prohibit sale of properties to individuals who don't plan to live there themselves for at least 2 or 3 years** -1. **Increase transparency when buying or selling a house through mandatory public offerings to prevent scooping by investors** -1. **Rent control to make _"mutating"_ houses less profitable** -1. **Increased socialized housing for poor and low-income families** +- **Build more (sustainable) durable houses** + +- **Prohibit sale of properties to individuals who don't plan to live there themselves for at least 2 or 3 years** + +- **Increase transparency when buying or selling a house through mandatory public offerings to prevent scooping by investors** + +- **Rent control to make _"mutating"_ houses less profitable** + +- **Increased socialized housing for poor and low-income families** Perhaps if we implement a few of these strategies we can make the housing market a little fairer and perhaps ensure that future generations will have the same opportunities current home-owners have. diff --git a/content/blog/2021-amsterdam-housing-market/mutations-table.png b/content/blog/2021-amsterdam-housing-market/mutations-table.png index 3488a5c..a489091 100644 Binary files a/content/blog/2021-amsterdam-housing-market/mutations-table.png and b/content/blog/2021-amsterdam-housing-market/mutations-table.png differ diff --git a/content/blog/2021-comparison-fa-pca-ica/sobar-72.csv b/content/blog/2021-comparison-fa-pca-ica/data/sobar-72.csv similarity index 100% rename from content/blog/2021-comparison-fa-pca-ica/sobar-72.csv rename to content/blog/2021-comparison-fa-pca-ica/data/sobar-72.csv diff --git a/content/blog/2021-comparison-fa-pca-ica/index.md b/content/blog/2021-comparison-fa-pca-ica/index.md index 00f9c7c..c2935b5 100644 --- a/content/blog/2021-comparison-fa-pca-ica/index.md +++ b/content/blog/2021-comparison-fa-pca-ica/index.md @@ -14,13 +14,19 @@ execute: fig.show: hold results: hold out.width: 80% +editor_options: + chunk_output_type: console --- This is just a very quick blog post outlining some of the commonalities and differences between factor analysis (FA), principal component analysis (PCA), and independent component analysis (ICA). I was inspired to write some of this down through some confusion caused in the lab by SPSS' apparent dual usage of the term "factor analysis" and "principal components". A few of my colleagues who use SPSS showed me the following screen: -{{< image src="spss-screenshot.png" alt="spss screenshot" >}} +{{< figure src="spss-screenshot.png" alt="spss screenshot" >}} -This screen shows up when you click `Analyze` -\> `Dimension Reduction` -\> `Factor`, which then opens a window called "Factor Analysis: Extraction" which lets you pick "Principal components" as a method. To put the (apparent) PCA method as a sub-section of factor analysis is misleading at best, and straight-up erronious at worst. The other options for the method here is "Principal axis factoring" (which is closer to traditional factor analysis) and "Maximum likelihood" ([source for screenshot and SPSS interface](https://stats.idre.ucla.edu/spss/seminars/efa-spss/)). If you're wondering if you're the first one to be confused by SPSS' choice to present this in such a way, you're not ([link](https://stats.stackexchange.com/questions/1576/what-are-the-differences-between-factor-analysis-and-principal-component-analysi), [link](https://stats.stackexchange.com/questions/24781/interpreting-discrepancies-between-r-and-spss-with-exploratory-factor-analysis)). +{{< sidenote br="2em" >}} +If you're wondering if you're the first one to be confused by SPSS' choice to present this in such a way, you're not ([link](https://stats.stackexchange.com/questions/1576/what-are-the-differences-between-factor-analysis-and-principal-component-analysi), [link](https://stats.stackexchange.com/questions/24781/interpreting-discrepancies-between-r-and-spss-with-exploratory-factor-analysis)). +{{< /sidenote >}} + +This screen shows up when you click `Analyze` -\> `Dimension Reduction` -\> `Factor`, which then opens a window called "Factor Analysis: Extraction" which lets you pick "Principal components" as a method. To put the (apparent) PCA method as a sub-section of factor analysis is misleading at best, and straight-up erronious at worst. The other options for the method here is "Principal axis factoring" (which is closer to traditional factor analysis) and "Maximum likelihood" ([source for screenshot and SPSS interface](https://stats.idre.ucla.edu/spss/seminars/efa-spss/)). Standard disclaimer: I'm not a statistician, and I'm definitely not confident enough to go in-depth into the mathematics of the different algorithms. Instead, I'll just run three common latent variable modeling/clustering methods, and show the difference in results when applied to the same data. Where-ever I feel confident, I will also elaborate on the underlying mathematical principles and concepts. It's a short post, and I'm sure there's levels of nuance and complexity I've missed. Please let me know if you think I've committed a major oversight. @@ -41,8 +47,8 @@ theme_set(theme_minimal()) We'll load the data into R, clean up the variable names, convert the outcome variable (`ca_cervix`) to a factor. We'll have a look at the dataset using some functions from `{skimr}`. This function will give us summary statistics and basic histograms of the different variables. ``` r -data <- read_csv("sobar-72.csv") |> - janitor::clean_names() |> +data <- read_csv("./data/sobar-72.csv") |> + janitor::clean_names() |> mutate(ca_cervix = as_factor(ca_cervix)) skim_summ <- skimr::skim_with(base = skimr::sfl()) @@ -96,8 +102,8 @@ Data summary Now let's only select the variables containing the risk factors (called features from here on). We'll also scale all the features to have a mean of 0 and a standard deviation of 1 using the `scale()` function. We can check what the new variable looks like using the `summary()` function. ``` r -data_features <- data |> - select(-ca_cervix) |> +data_features <- data |> + select(-ca_cervix) |> mutate(across(everything(), ~ scale(.x))) summary(data_features$attitude_consistency) @@ -114,17 +120,23 @@ summary(data_features$attitude_consistency) So now we have a data frame with 72 entries and 19 normalized columns, each representing a feature that may or may not predict cervical cancer. We can create a correlation matrix to visualize the degree of correlation between the different features. For this we simply run `cor()` on the data frame with the features, transform the output to a data frame in long format and then visualize it using `ggplot()` and `geom_tile()`. ``` r -cor(data_features) |> - as_tibble() %>% - mutate(feature_y = names(.)) |> - pivot_longer(cols = -feature_y, names_to = "feature_x", values_to = "correlation") |> - mutate(feature_y = fct_rev(feature_y)) |> - ggplot(aes(x = feature_x, y = feature_y, fill = correlation)) + - geom_tile() + - labs(x = NULL, - y = NULL) + - scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) + - coord_fixed() + +cor(data_features) |> + as_tibble() |> + mutate(feature_y = names(data_features)) |> + pivot_longer( + cols = -feature_y, + names_to = "feature_x", + values_to = "correlation" + ) |> + mutate(feature_y = fct_rev(feature_y)) |> + ggplot(aes(x = feature_x, y = feature_y, fill = correlation)) + + geom_tile() + + labs( + x = NULL, + y = NULL + ) + + scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) + + coord_fixed() + theme(axis.text.x = element_text(hjust = 1, angle = 30)) ``` @@ -138,6 +150,10 @@ Let's now dive into the approaches we'll use. We'll discuss three here, and if t ## Selecting the number of components +{{< sidenote br="6em" >}} +Icasso is implemented in MATLAB, which I won't bore you with here, but it seems someone created a [Python port](https://github.com/Teekuningas/icasso) also +{{< /sidenote >}} + For factor analysis and ICA we need to provide the number of factors we want to extract. We'll use the same number of factors/components throughout this tutorial (also for PCA). Selection of the optimal number of factors/components is a fairly arbitrary process which I won't go into now. In short, before writing this I ran PCA and a tool called [icasso](https://research.ics.aalto.fi/ica/icasso/). *Icasso* runs an ICA algorithm a number of times and provides a number of parameters on the stability of the clusters at different thresholds, this approach is very data-driven. A more common and easier way to get some data-driven insight into the optimal number of clusters is using the "elbow"-method using PCA, eigenvalues of the components, and the cumulative variance explained by the components (we'll show those later). However, in the end, you should also look at the weight matrix of the different cluster thresholds and it becomes a fairly arbitrary process. In this case, the *icasso* showed that 7 components was good (but not the best), the weight matrix looked okay, and 7 components explained more than 80% of the variance in the PCA. I went for 7 components in the end also because it served the purpose of this blogpost quite well, but I think different thresholds are valid and you could make a case for different ones based on the data, based on the interpretation of the weight matrix, etc. This process is a bit of an art and a science combined. ``` r @@ -146,12 +162,18 @@ n_comps <- 7 ## Factor Analysis -So, let's run the factor analysis. Technically speaking, factor analysis isn't a clustering method but rather a latent variable modeling method [source](https://stats.stackexchange.com/questions/241726/understanding-exploratory-factor-analysis-some-points-for-clarification). The primary aim of a factor analysis is the reconstruction of correlations/covariances between variables. Maximizing explained variance of the factors is only a secondary aim and we'll get to why that is relevant in the PCA section. +So, let's run the factor analysis. Technically speaking, factor analysis isn't a clustering method but rather a latent variable modeling method ([source](https://stats.stackexchange.com/questions/241726/understanding-exploratory-factor-analysis-some-points-for-clarification)). The primary aim of a factor analysis is the reconstruction of correlations/covariances between variables. Maximizing explained variance of the factors is only a secondary aim and we'll get to why that is relevant in the PCA section. We've established we want 7 factors. The factor analysis method is implemented in R through the `factanal()` function (see [here](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/factanal%20for%20the%20documentation). This function applies a common factor model using the maximum likelihood method. We'll simply provide it with our data frame, the number of factors we want to extract, and we'll ask to provide Bartlett's weighted least-squares scores as well. We can apply a "rotation" to the factors to make them reduce the complexity of the factor loadings and make them easier to interpret, here we'll use the `varimax` option. Varimax maximizes the sum of the variances of the squared loadings. Then we'll print the model to see the results (and sort so the loadings are ordered). The output may be a bit long. ``` r -fa_model <- factanal(data_features, factors = n_comps, scores = "Bartlett", rotation = "varimax") +fa_model <- factanal( + data_features, + factors = n_comps, + scores = "Bartlett", + rotation = "varimax" +) + print(fa_model, sort = TRUE) ``` @@ -234,19 +256,26 @@ print(fa_model, sort = TRUE) We may be tempted to immediately look at the *p*-value at the end of the output. This *p*-value denotes whether the assumption of perfect fit can be rejected. If this *p*-value is below 0.05 or 0.01 we can reject the hypothesis of perfect fit, meaning that we could probably try a different method or try a different number of factors. In this case, the *p*-value is larger than 0.05 so we cannot reject the hypothesis of perfect fit. -The "Loadings" section of the results show a make-shift weight matrix, but in order to further interpret these results, let's create a plot showing the weight matrix. We'll get the results from the factor analysis model we created earlier using the `tidy()` function from `{broom}` and convert it to long format. We'll then create a weight matrix much in the same way we did earlier. +The "Loadings" section of the results show a make-shift weight matrix, but in order to further interpret these results, let's create a plot showing the weight matrix. We'll get the results from the factor analysis model we created earlier using the `tidy()` function from the `{broom}` package and convert it to long format. We'll then create a weight matrix much in the same way we did earlier. ``` r -fa_weight_matrix <- broom::tidy(fa_model) |> - pivot_longer(starts_with("fl"), names_to = "factor", values_to = "loading") - -fa_loading_plot <- ggplot(fa_weight_matrix, aes(x = factor, y = variable, fill = loading)) + - geom_tile() + - labs(title = "FA loadings", - x = NULL, - y = NULL) + - scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) + - coord_fixed(ratio = 1/2) +fa_weight_matrix <- broom::tidy(fa_model) |> + pivot_longer(starts_with("fl"), + names_to = "factor", values_to = "loading" + ) + +fa_loading_plot <- ggplot( + fa_weight_matrix, + aes(x = factor, y = variable, fill = loading) +) + + geom_tile() + + labs( + title = "FA loadings", + x = NULL, + y = NULL + ) + + scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) + + coord_fixed(ratio = 1 / 2) print(fa_loading_plot) ``` @@ -258,24 +287,29 @@ Here we can more easily see that there's two strong clusters in Factor 1 and Fac Lastly, I think it would be interesting to see how the different factors relate to each other. We'll take the Bartlett's scores and correlate them with each other much like before and create a correlation matrix like before. ``` r -fa_model$scores |> - cor() |> - data.frame() |> - rownames_to_column("factor_x") |> - pivot_longer(cols = -factor_x, names_to = "factor_y", values_to = "correlation") |> - ggplot(aes(x = factor_x, y = factor_y, fill = correlation)) + +fa_model$scores |> + cor() |> + data.frame() |> + rownames_to_column("factor_x") |> + pivot_longer( + cols = -factor_x, + names_to = "factor_y", values_to = "correlation" + ) |> + ggplot(aes(x = factor_x, y = factor_y, fill = correlation)) + geom_tile() + - geom_text(aes(label = round(correlation,4)), color = "white") + - labs(title = "Correlation between FA scores", - x = NULL, - y = NULL) + - scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) + + geom_text(aes(label = round(correlation, 4)), color = "white") + + labs( + title = "Correlation between FA scores", + x = NULL, + y = NULL + ) + + scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) + coord_equal() ```
-We can see little correlation but certainly a few non-zero correlations also. In particular Factor 5 and Factor 7 seem to correlate to some extent at least and there are a few others with some minor correlations, e.g. Factor 1 and Factor 3, as well as Factor 3 and Factor 6. We'll compare this later with the other algorithms.
+We can see little correlation but certainly a few non-zero correlations also. In particular Factor 5 and Factor 7 seem to correlate to some extent at least and there are a few others with some minor correlations, e.g. Factor 1 and Factor 3, as well as Factor 5 and Factor 6. We'll compare this later with the other algorithms.
## Principal Component Analysis
@@ -285,7 +319,11 @@ Principal component analysis can reliably be classfied as a clustering method (a
I can recommend this paper as a great primer to PCA methods. It goes over a few concepts very relevant for PCA methods as well as clustering methods in general.
-Now, let's run the PCA. In R there's two functions built-in to run a principal component analysis, here we'll use the `prcomp()`function (the other being `princomp()`, but `prcomp()` is preferred for reasons beyond the scope of this post). The `prcomp()` function contains a few options we can play with, but in my experience it works fine out of the box if you've normalized the data beforehand ([link to documentation](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/prcomp)). So we'll simply provide the data frame with the features. In addition, we'll also calculate the variance explained by each component. We do that by simply taking the standard deviation calculated by the PCA and squaring it, we'll save it in a new field called `variance`.
+{{< sidenote br="1em" >}}
+For some more info on the difference between `prcomp()` and `princomp()` see [this](https://stats.stackexchange.com/questions/20101/what-is-the-difference-between-r-functions-prcomp-and-princomp) thread on CrossValidated
+{{< /sidenote >}}
+
+Now, let's run the PCA. In R there's two functions built-in to run a principal component analysis, here we'll use the `prcomp()` function (the other being `princomp()`, but `prcomp()` is preferred for reasons beyond the scope of this post). The `prcomp()` function contains a few options we can play with, but in my experience it works fine out of the box if you've normalized the data beforehand ([link to documentation](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/prcomp)). So we'll simply provide the data frame with the features. In addition, we'll also calculate the variance explained by each component. We do that by simply taking the standard deviation calculated by the PCA and squaring it, we'll save it in a new field called `variance`.
``` r
pc_model <- prcomp(data_features)
@@ -296,40 +334,46 @@ pc_model$variance <- pc_model$sdev^2
Next we can make a simple scree plot using the variance we calculate above. We'll create a plot with the principal components on the x-axis and the eigenvalue on the y-axis. The scree plot is a very popular plot to visualize features of a PCA. In this plot the elbow is quite clearly at principal component 3, but as discussed, the scree plot is not the best nor the only way to determine the optimal number of components. In the code below I also added a calculation for the cumulative variance (`cum_variance`) which showed that a little more than 80% of the variance is captured in the first 7 components, while the first 3 components combined capture only 56%.
``` r
-pc_model$variance |>
+pc_model$variance |>
as_tibble() |>
- rename(eigenvalue = value) |>
- rownames_to_column("comp") |>
- mutate(comp = parse_number(comp),
- cum_variance = cumsum(eigenvalue)/sum(eigenvalue)) |>
- ggplot(aes(x = comp, y = eigenvalue)) +
+ rename(eigenvalue = value) |>
+ rownames_to_column("comp") |>
+ mutate(
+ comp = parse_number(comp),
+ cum_variance = cumsum(eigenvalue) / sum(eigenvalue)
+ ) |>
+ ggplot(aes(x = comp, y = eigenvalue)) +
geom_hline(yintercept = 1) +
- geom_line(size = 1) +
+ geom_line(linewidth = 1) +
geom_point(size = 3)
```
- Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
- ℹ Please use `linewidth` instead.
-
We'll also create a weight matrix again, based on the rotation from the PCA. We'll create the weight matrix much in the same way as before. A PCA by its very nature returns an equal number of components as the number of variables put in, however, we're interested in just the first 7 components, so we'll select just those using the `filter()` function.
``` r
-pc_weight_matrix <- pc_model$rotation |>
- data.frame() |>
- rownames_to_column("variable") |>
- pivot_longer(starts_with("PC"), names_to = "prin_comp", values_to = "loading")
-
-pca_loading_plot <- pc_weight_matrix |>
- filter(parse_number(prin_comp) <= n_comps) |>
- ggplot(aes(x = reorder(prin_comp, parse_number(prin_comp)), y = variable, fill = loading)) +
- geom_tile() +
- labs(title = "PCA loadings",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) +
- coord_fixed(ratio = 1/2)
+pc_weight_matrix <- pc_model$rotation |>
+ data.frame() |>
+ rownames_to_column("variable") |>
+ pivot_longer(starts_with("PC"),
+ names_to = "prin_comp", values_to = "loading"
+ )
+
+pca_loading_plot <- pc_weight_matrix |>
+ filter(parse_number(prin_comp) <= n_comps) |>
+ ggplot(aes(
+ x = reorder(prin_comp, parse_number(prin_comp)),
+ y = variable, fill = loading
+ )) +
+ geom_tile() +
+ labs(
+ title = "PCA loadings",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) +
+ coord_fixed(ratio = 1 / 2)
print(pca_loading_plot)
```
@@ -341,20 +385,27 @@ One thing that immediately jumps out is that PC1 and PC2 are nearly identical to
We can also make a correlation matrix for the different principal components. We'll use the `x` field and otherwise create the correlation matrix the same way as before:
``` r
-pc_model$x |>
- cor() |>
- data.frame() |>
- rownames_to_column("comp_x") |>
- pivot_longer(cols = starts_with("PC"), names_to = "comp_y", values_to = "correlation") |>
- filter(parse_number(comp_x) <= n_comps,
- parse_number(comp_y) <= n_comps) |>
- ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
+pc_model$x |>
+ cor() |>
+ data.frame() |>
+ rownames_to_column("comp_x") |>
+ pivot_longer(
+ cols = starts_with("PC"),
+ names_to = "comp_y", values_to = "correlation"
+ ) |>
+ filter(
+ parse_number(comp_x) <= n_comps,
+ parse_number(comp_y) <= n_comps
+ ) |>
+ ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
geom_tile() +
- geom_text(aes(label = round(correlation,4)), color = "white") +
- labs(title = "Correlation between PCs",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) +
+ geom_text(aes(label = round(correlation, 4)), color = "white") +
+ labs(
+ title = "Correlation between PCs",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) +
coord_equal()
```
@@ -387,10 +438,10 @@ pc_manual <- as.matrix(data_features) %*% eigenvector
Let's look at the scree plot:
``` r
-tibble(eigenvalues) |>
- ggplot(aes(x = seq_along(eigenvalues), y = eigenvalues)) +
+tibble(eigenvalues) |>
+ ggplot(aes(x = seq_along(eigenvalues), y = eigenvalues)) +
geom_hline(yintercept = 1) +
- geom_line(size = 1) +
+ geom_line(linewidth = 1) +
geom_point(size = 3)
```
@@ -399,9 +450,9 @@ tibble(eigenvalues) |>
Looks identical to the previous one. Let's also look at the correlation matrix between the principal components.
``` r
-data.frame(pc_manual) |>
- cor() %>%
- round(., 4)
+data.frame(pc_manual) |>
+ cor() |>
+ round(x = _, digits = 4)
```
X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15 X16 X17 X18 X19
@@ -429,6 +480,10 @@ Yup, also still 0 across the board. Calculating a PCA by just using matrix manip
## Independent Component Analysis
+{{< sidenote br="14em" >}}
+If you're feeling particularly *mathematical*, you can read find a paper [here](https://www.iiis.org/CDs2017/CD2017Spring/papers/ZA832BA.pdf) that compares different algorithms
+{{< /sidenote >}}
+
While PCA attempts to find components explaining the maximum degree of covariance or correlation, an ICA attemps to find components with maximum statistical independence. There's very complicated nuance here where PCA components are orthogonal and uncorrelated to each other and ICA components are merely statistically independent, which is a very subtle nuance. In practice, it'll mean that ICA components also have a practically zero correlation. The main difference is in how the components are obtained. Like with factor analysis, most ICA algorithms require you to provide a number of components up front. The FastICA algorithm we'll use here is a version of an ICA implementation. There's also InfoMax and JADE to name two other implementations. I couldn't tell you the difference between these ICA algorithms. The FastICA is implemented in R through the `fastICA()` function and the eponymous `{fastICA}` package ([link to documentation](https://www.rdocumentation.org/packages/fastICA/versions/1.2-2/topics/fastICA)).
``` r
@@ -438,18 +493,26 @@ ica_model <- fastICA(data_features, n.comp = n_comps)
Let's create a weight matrix again. The output from the `fastICA()` doesn't provide useful names, but the [documentation](https://www.rdocumentation.org/packages/fastICA/versions/1.2-2/topics/fastICA) provides sufficient information. To create the weight matrix we take the `A` field, transpose it, get the right names to the right places and then create the plot like we've done several times now.
``` r
-ica_weight_matrix <- data.frame(t(ica_model$A)) |>
+ica_weight_matrix <- data.frame(t(ica_model$A)) |>
rename_with(~ str_glue("IC{seq(.)}")) |>
mutate(variable = names(data_features)) |>
- pivot_longer(cols = starts_with("IC"), names_to = "ic", values_to = "loading")
-
-ica_loading_plot <- ggplot(ica_weight_matrix, aes(x = ic, y = variable, fill = loading)) +
- geom_tile() +
- labs(title = "ICA loadings",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) +
- coord_fixed(ratio = 1/2)
+ pivot_longer(
+ cols = starts_with("IC"),
+ names_to = "ic", values_to = "loading"
+ )
+
+ica_loading_plot <- ggplot(
+ ica_weight_matrix,
+ aes(x = ic, y = variable, fill = loading)
+) +
+ geom_tile() +
+ labs(
+ title = "ICA loadings",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) +
+ coord_fixed(ratio = 1 / 2)
print(ica_loading_plot)
```
@@ -461,18 +524,23 @@ The FastICA method doesn't rank the components based on variance like factor ana
Again, we can also visualize the correlation between the different components.
``` r
-ica_model$S |>
- cor() |>
- data.frame() |>
- rownames_to_column("comp_x") |>
- pivot_longer(cols = starts_with("X"), names_to = "comp_y", values_to = "correlation") |>
- ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
+ica_model$S |>
+ cor() |>
+ data.frame() |>
+ rownames_to_column("comp_x") |>
+ pivot_longer(
+ cols = starts_with("X"),
+ names_to = "comp_y", values_to = "correlation"
+ ) |>
+ ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
geom_tile() +
- geom_text(aes(label = round(correlation,4)), color = "white") +
- labs(title = "Correlation between ICs",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) +
+ geom_text(aes(label = round(correlation, 4)), color = "white") +
+ labs(
+ title = "Correlation between ICs",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) +
coord_equal()
```
@@ -484,34 +552,38 @@ Okay, let's now compare the three approaches and put the loading matrices side b
``` r
all_weight_matrices <- bind_rows(
- fa_weight_matrix |>
- rename(comp = factor) |>
+ fa_weight_matrix |>
+ rename(comp = factor) |>
mutate(alg = "FA"),
- pc_weight_matrix |>
- rename(comp = prin_comp) |>
- mutate(alg = "PCA"),
- ica_weight_matrix |>
- rename(comp = ic) |>
+ pc_weight_matrix |>
+ rename(comp = prin_comp) |>
+ mutate(alg = "PCA"),
+ ica_weight_matrix |>
+ rename(comp = ic) |>
mutate(alg = "ICA")
)
-all_weight_matrices |>
- filter(parse_number(comp) <= n_comps) |>
- mutate(alg = str_glue("{alg} loadings"),
- alg = as_factor(alg)) |>
+all_weight_matrices |>
+ filter(parse_number(comp) <= n_comps) |>
+ mutate(
+ alg = str_glue("{alg} loadings"),
+ alg = as_factor(alg)
+ ) |>
ggplot(aes(x = comp, y = variable, fill = loading)) +
- geom_tile() +
- labs(x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) +
- facet_wrap(~ alg, scales = "free_x")
+ geom_tile() +
+ labs(
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) +
+ facet_wrap(~alg, scales = "free_x")
```
Here we can most clearly see the overlap between the three methods, Factor 1, PC1, and IC 6 capture essentially the same information. The same goes for Factor 2, PC2, and IC 4. Other than that we can see that the other components vary quite markedly. I wouldn't be comfortable calling any of the other components "fairly similar" to another. You could see how some variables load together with multiple methods, but then the components those are captured in also have other information or miss information. We already discussed IC7 consisting mostly of a single variable, and a similar thing happens with Factor 4, but for a different variable.
-### BONUS: Hierarchical clustering
+## BONUS: Hierarchical clustering
I'll quickly go over hierarchical clustering too, it's simple and easy to interpret. Hierarchical clustering works by taking your variables and clustering them first into two groups, then three, then four, and so on. It looks at similarity and a concept called "Euclidian distance" (other methods are available) between the variables and determines how to separate. Essentially, hierarchical clustering works by iteratively separating variables into groups until every variable is on its own. It does so rather aggressively, with the previous methods it's possible for a variable to be part of two clusters, with hierarchical clustering it's part of a single cluster only. This approach makes it an easy way to see how variables cluster together at different thresholds.
@@ -540,7 +612,7 @@ hclust_weight_matrix <- cutree(hclust_model, k = n_comps)
The `cutree()` function assigns a cluster to each of the variables. It looks at the tree and determines where to cut the tree to get the desired number of branches and then tells you the composition of the branches. We can recreate this ourselves by simply adding a `geom_hline()` to the dendrogram. With some trial and error, it seems like cutting the tree at `y = 10.5` will give us 7 clusters.
``` r
-ggdendro::ggdendrogram(hclust_model) +
+ggdendro::ggdendrogram(hclust_model) +
geom_hline(yintercept = 10.5, color = "firebrick")
```
@@ -549,16 +621,20 @@ ggdendro::ggdendrogram(hclust_model) +
Let's look at how the clusters are made up according to the hierarchical clustering model. This isn't really a weight matrix, but rather a definition of the clusters. The "loadings" here are not numerical, but rather 1 or 0.
``` r
-hclust_weight_matrix %>%
- data.frame() |>
- janitor::clean_names() |>
- rename(cluster = x) |>
- rownames_to_column("variable") |>
- ggplot(aes(x = as_factor(cluster), y = variable, fill = as_factor(cluster))) +
- geom_tile() +
- labs(x = NULL,
- y = NULL,
- fill = "cluster") +
+hclust_weight_matrix |>
+ data.frame() |>
+ rename(cluster = hclust_weight_matrix) |>
+ rownames_to_column("variable") |>
+ ggplot(aes(
+ x = as_factor(cluster), y = variable,
+ fill = as_factor(cluster)
+ )) +
+ geom_tile() +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = "cluster"
+ ) +
scico::scale_fill_scico_d(palette = "batlow")
```
diff --git a/content/blog/2021-comparison-fa-pca-ica/index.qmd b/content/blog/2021-comparison-fa-pca-ica/index.qmd
index 8cc0c05..07d13e8 100644
--- a/content/blog/2021-comparison-fa-pca-ica/index.qmd
+++ b/content/blog/2021-comparison-fa-pca-ica/index.qmd
@@ -14,13 +14,19 @@ execute:
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
This is just a very quick blog post outlining some of the commonalities and differences between factor analysis (FA), principal component analysis (PCA), and independent component analysis (ICA). I was inspired to write some of this down through some confusion caused in the lab by SPSS' apparent dual usage of the term "factor analysis" and "principal components". A few of my colleagues who use SPSS showed me the following screen:
-{{{< image src="spss-screenshot.png" alt="spss screenshot" >}}}
+{{{< figure src="spss-screenshot.png" alt="spss screenshot" >}}}
-This screen shows up when you click `Analyze` -> `Dimension Reduction` -> `Factor`, which then opens a window called "Factor Analysis: Extraction" which lets you pick "Principal components" as a method. To put the (apparent) PCA method as a sub-section of factor analysis is misleading at best, and straight-up erronious at worst. The other options for the method here is "Principal axis factoring" (which is closer to traditional factor analysis) and "Maximum likelihood" ([source for screenshot and SPSS interface](https://stats.idre.ucla.edu/spss/seminars/efa-spss/)). If you're wondering if you're the first one to be confused by SPSS' choice to present this in such a way, you're not ([link](https://stats.stackexchange.com/questions/1576/what-are-the-differences-between-factor-analysis-and-principal-component-analysi), [link](https://stats.stackexchange.com/questions/24781/interpreting-discrepancies-between-r-and-spss-with-exploratory-factor-analysis)).
+{{{< sidenote br="2em" >}}}
+If you're wondering if you're the first one to be confused by SPSS' choice to present this in such a way, you're not ([link](https://stats.stackexchange.com/questions/1576/what-are-the-differences-between-factor-analysis-and-principal-component-analysi), [link](https://stats.stackexchange.com/questions/24781/interpreting-discrepancies-between-r-and-spss-with-exploratory-factor-analysis)).
+{{{< /sidenote >}}}
+
+This screen shows up when you click `Analyze` -> `Dimension Reduction` -> `Factor`, which then opens a window called "Factor Analysis: Extraction" which lets you pick "Principal components" as a method. To put the (apparent) PCA method as a sub-section of factor analysis is misleading at best, and straight-up erronious at worst. The other options for the method here is "Principal axis factoring" (which is closer to traditional factor analysis) and "Maximum likelihood" ([source for screenshot and SPSS interface](https://stats.idre.ucla.edu/spss/seminars/efa-spss/)).
Standard disclaimer: I'm not a statistician, and I'm definitely not confident enough to go in-depth into the mathematics of the different algorithms. Instead, I'll just run three common latent variable modeling/clustering methods, and show the difference in results when applied to the same data. Where-ever I feel confident, I will also elaborate on the underlying mathematical principles and concepts. It's a short post, and I'm sure there's levels of nuance and complexity I've missed. Please let me know if you think I've committed a major oversight.
@@ -47,8 +53,8 @@ We'll load the data into R, clean up the variable names, convert the outcome var
#| label: load-data
#| message: false
-data <- read_csv("sobar-72.csv") |>
- janitor::clean_names() |>
+data <- read_csv("./data/sobar-72.csv") |>
+ janitor::clean_names() |>
mutate(ca_cervix = as_factor(ca_cervix))
skim_summ <- skimr::skim_with(base = skimr::sfl())
@@ -60,8 +66,8 @@ Now let's only select the variables containing the risk factors (called features
```{r}
#| label: scale-data
-data_features <- data |>
- select(-ca_cervix) |>
+data_features <- data |>
+ select(-ca_cervix) |>
mutate(across(everything(), ~ scale(.x)))
summary(data_features$attitude_consistency)
@@ -72,17 +78,23 @@ So now we have a data frame with 72 entries and 19 normalized columns, each repr
```{r}
#| label: corr-matrix-original
-cor(data_features) |>
- as_tibble() %>%
- mutate(feature_y = names(.)) |>
- pivot_longer(cols = -feature_y, names_to = "feature_x", values_to = "correlation") |>
- mutate(feature_y = fct_rev(feature_y)) |>
- ggplot(aes(x = feature_x, y = feature_y, fill = correlation)) +
- geom_tile() +
- labs(x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) +
- coord_fixed() +
+cor(data_features) |>
+ as_tibble() |>
+ mutate(feature_y = names(data_features)) |>
+ pivot_longer(
+ cols = -feature_y,
+ names_to = "feature_x",
+ values_to = "correlation"
+ ) |>
+ mutate(feature_y = fct_rev(feature_y)) |>
+ ggplot(aes(x = feature_x, y = feature_y, fill = correlation)) +
+ geom_tile() +
+ labs(
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) +
+ coord_fixed() +
theme(axis.text.x = element_text(hjust = 1, angle = 30))
```
@@ -94,6 +106,10 @@ Let's now dive into the approaches we'll use. We'll discuss three here, and if t
## Selecting the number of components
+{{{< sidenote br="6em" >}}}
+Icasso is implemented in MATLAB, which I won't bore you with here, but it seems someone created a [Python port](https://github.com/Teekuningas/icasso) also
+{{{< /sidenote >}}}
+
For factor analysis and ICA we need to provide the number of factors we want to extract. We'll use the same number of factors/components throughout this tutorial (also for PCA). Selection of the optimal number of factors/components is a fairly arbitrary process which I won't go into now. In short, before writing this I ran PCA and a tool called [icasso](https://research.ics.aalto.fi/ica/icasso/). _Icasso_ runs an ICA algorithm a number of times and provides a number of parameters on the stability of the clusters at different thresholds, this approach is very data-driven. A more common and easier way to get some data-driven insight into the optimal number of clusters is using the "elbow"-method using PCA, eigenvalues of the components, and the cumulative variance explained by the components (we'll show those later). However, in the end, you should also look at the weight matrix of the different cluster thresholds and it becomes a fairly arbitrary process. In this case, the _icasso_ showed that 7 components was good (but not the best), the weight matrix looked okay, and 7 components explained more than 80% of the variance in the PCA. I went for 7 components in the end also because it served the purpose of this blogpost quite well, but I think different thresholds are valid and you could make a case for different ones based on the data, based on the interpretation of the weight matrix, etc. This process is a bit of an art and a science combined.
```{r}
@@ -105,34 +121,47 @@ n_comps <- 7
## Factor Analysis
-So, let's run the factor analysis. Technically speaking, factor analysis isn't a clustering method but rather a latent variable modeling method [source](https://stats.stackexchange.com/questions/241726/understanding-exploratory-factor-analysis-some-points-for-clarification). The primary aim of a factor analysis is the reconstruction of correlations/covariances between variables. Maximizing explained variance of the factors is only a secondary aim and we'll get to why that is relevant in the PCA section.
+So, let's run the factor analysis. Technically speaking, factor analysis isn't a clustering method but rather a latent variable modeling method ([source](https://stats.stackexchange.com/questions/241726/understanding-exploratory-factor-analysis-some-points-for-clarification)). The primary aim of a factor analysis is the reconstruction of correlations/covariances between variables. Maximizing explained variance of the factors is only a secondary aim and we'll get to why that is relevant in the PCA section.
We've established we want 7 factors. The factor analysis method is implemented in R through the `factanal()` function (see [here](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/factanal for the documentation). This function applies a common factor model using the maximum likelihood method. We'll simply provide it with our data frame, the number of factors we want to extract, and we'll ask to provide Bartlett's weighted least-squares scores as well. We can apply a "rotation" to the factors to make them reduce the complexity of the factor loadings and make them easier to interpret, here we'll use the `varimax` option. Varimax maximizes the sum of the variances of the squared loadings. Then we'll print the model to see the results (and sort so the loadings are ordered). The output may be a bit long.
```{r}
#| label: fa
-fa_model <- factanal(data_features, factors = n_comps, scores = "Bartlett", rotation = "varimax")
+fa_model <- factanal(
+ data_features,
+ factors = n_comps,
+ scores = "Bartlett",
+ rotation = "varimax"
+)
+
print(fa_model, sort = TRUE)
```
We may be tempted to immediately look at the _p_-value at the end of the output. This _p_-value denotes whether the assumption of perfect fit can be rejected. If this _p_-value is below 0.05 or 0.01 we can reject the hypothesis of perfect fit, meaning that we could probably try a different method or try a different number of factors. In this case, the _p_-value is larger than 0.05 so we cannot reject the hypothesis of perfect fit.
-The "Loadings" section of the results show a make-shift weight matrix, but in order to further interpret these results, let's create a plot showing the weight matrix. We'll get the results from the factor analysis model we created earlier using the `tidy()` function from `{broom}` and convert it to long format. We'll then create a weight matrix much in the same way we did earlier.
+The "Loadings" section of the results show a make-shift weight matrix, but in order to further interpret these results, let's create a plot showing the weight matrix. We'll get the results from the factor analysis model we created earlier using the `tidy()` function from the `{broom}` package and convert it to long format. We'll then create a weight matrix much in the same way we did earlier.
```{r}
#| label: fa-weight-matrix
-fa_weight_matrix <- broom::tidy(fa_model) |>
- pivot_longer(starts_with("fl"), names_to = "factor", values_to = "loading")
+fa_weight_matrix <- broom::tidy(fa_model) |>
+ pivot_longer(starts_with("fl"),
+ names_to = "factor", values_to = "loading"
+ )
-fa_loading_plot <- ggplot(fa_weight_matrix, aes(x = factor, y = variable, fill = loading)) +
- geom_tile() +
- labs(title = "FA loadings",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) +
- coord_fixed(ratio = 1/2)
+fa_loading_plot <- ggplot(
+ fa_weight_matrix,
+ aes(x = factor, y = variable, fill = loading)
+) +
+ geom_tile() +
+ labs(
+ title = "FA loadings",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) +
+ coord_fixed(ratio = 1 / 2)
print(fa_loading_plot)
```
@@ -144,22 +173,27 @@ Lastly, I think it would be interesting to see how the different factors relate
```{r}
#| label: fa-corr-matrix
-fa_model$scores |>
- cor() |>
- data.frame() |>
- rownames_to_column("factor_x") |>
- pivot_longer(cols = -factor_x, names_to = "factor_y", values_to = "correlation") |>
- ggplot(aes(x = factor_x, y = factor_y, fill = correlation)) +
+fa_model$scores |>
+ cor() |>
+ data.frame() |>
+ rownames_to_column("factor_x") |>
+ pivot_longer(
+ cols = -factor_x,
+ names_to = "factor_y", values_to = "correlation"
+ ) |>
+ ggplot(aes(x = factor_x, y = factor_y, fill = correlation)) +
geom_tile() +
- geom_text(aes(label = round(correlation,4)), color = "white") +
- labs(title = "Correlation between FA scores",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) +
+ geom_text(aes(label = round(correlation, 4)), color = "white") +
+ labs(
+ title = "Correlation between FA scores",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) +
coord_equal()
```
-We can see little correlation but certainly a few non-zero correlations also. In particular Factor 5 and Factor 7 seem to correlate to some extent at least and there are a few others with some minor correlations, e.g. Factor 1 and Factor 3, as well as Factor 3 and Factor 6. We'll compare this later with the other algorithms.
+We can see little correlation but certainly a few non-zero correlations also. In particular Factor 5 and Factor 7 seem to correlate to some extent at least and there are a few others with some minor correlations, e.g. Factor 1 and Factor 3, as well as Factor 5 and Factor 6. We'll compare this later with the other algorithms.
## Principal Component Analysis
@@ -170,7 +204,11 @@ Principal component analysis can reliably be classfied as a clustering method (a
I can recommend this paper as a great primer to PCA methods. It goes over a few concepts very relevant for PCA methods as well as clustering methods in general.
-Now, let's run the PCA. In R there's two functions built-in to run a principal component analysis, here we'll use the `prcomp()`function (the other being `princomp()`, but `prcomp()` is preferred for reasons beyond the scope of this post). The `prcomp()` function contains a few options we can play with, but in my experience it works fine out of the box if you've normalized the data beforehand ([link to documentation](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/prcomp)). So we'll simply provide the data frame with the features. In addition, we'll also calculate the variance explained by each component. We do that by simply taking the standard deviation calculated by the PCA and squaring it, we'll save it in a new field called `variance`.
+{{{< sidenote br="1em" >}}}
+For some more info on the difference between `prcomp()` and `princomp()` see [this](https://stats.stackexchange.com/questions/20101/what-is-the-difference-between-r-functions-prcomp-and-princomp) thread on CrossValidated
+{{{< /sidenote >}}}
+
+Now, let's run the PCA. In R there's two functions built-in to run a principal component analysis, here we'll use the `prcomp()` function (the other being `princomp()`, but `prcomp()` is preferred for reasons beyond the scope of this post). The `prcomp()` function contains a few options we can play with, but in my experience it works fine out of the box if you've normalized the data beforehand ([link to documentation](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/prcomp)). So we'll simply provide the data frame with the features. In addition, we'll also calculate the variance explained by each component. We do that by simply taking the standard deviation calculated by the PCA and squaring it, we'll save it in a new field called `variance`.
```{r}
#| label: pca
@@ -185,15 +223,17 @@ Next we can make a simple scree plot using the variance we calculate above. We'l
```{r}
#| label: pca-scree
-pc_model$variance |>
+pc_model$variance |>
as_tibble() |>
- rename(eigenvalue = value) |>
- rownames_to_column("comp") |>
- mutate(comp = parse_number(comp),
- cum_variance = cumsum(eigenvalue)/sum(eigenvalue)) |>
- ggplot(aes(x = comp, y = eigenvalue)) +
+ rename(eigenvalue = value) |>
+ rownames_to_column("comp") |>
+ mutate(
+ comp = parse_number(comp),
+ cum_variance = cumsum(eigenvalue) / sum(eigenvalue)
+ ) |>
+ ggplot(aes(x = comp, y = eigenvalue)) +
geom_hline(yintercept = 1) +
- geom_line(size = 1) +
+ geom_line(linewidth = 1) +
geom_point(size = 3)
```
@@ -202,20 +242,27 @@ We'll also create a weight matrix again, based on the rotation from the PCA. We'
```{r}
#| label: pca-weight-matrix
-pc_weight_matrix <- pc_model$rotation |>
- data.frame() |>
- rownames_to_column("variable") |>
- pivot_longer(starts_with("PC"), names_to = "prin_comp", values_to = "loading")
-
-pca_loading_plot <- pc_weight_matrix |>
- filter(parse_number(prin_comp) <= n_comps) |>
- ggplot(aes(x = reorder(prin_comp, parse_number(prin_comp)), y = variable, fill = loading)) +
- geom_tile() +
- labs(title = "PCA loadings",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) +
- coord_fixed(ratio = 1/2)
+pc_weight_matrix <- pc_model$rotation |>
+ data.frame() |>
+ rownames_to_column("variable") |>
+ pivot_longer(starts_with("PC"),
+ names_to = "prin_comp", values_to = "loading"
+ )
+
+pca_loading_plot <- pc_weight_matrix |>
+ filter(parse_number(prin_comp) <= n_comps) |>
+ ggplot(aes(
+ x = reorder(prin_comp, parse_number(prin_comp)),
+ y = variable, fill = loading
+ )) +
+ geom_tile() +
+ labs(
+ title = "PCA loadings",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) +
+ coord_fixed(ratio = 1 / 2)
print(pca_loading_plot)
```
@@ -227,20 +274,27 @@ We can also make a correlation matrix for the different principal components. We
```{r}
#| label: pca-corr-matrix
-pc_model$x |>
- cor() |>
- data.frame() |>
- rownames_to_column("comp_x") |>
- pivot_longer(cols = starts_with("PC"), names_to = "comp_y", values_to = "correlation") |>
- filter(parse_number(comp_x) <= n_comps,
- parse_number(comp_y) <= n_comps) |>
- ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
+pc_model$x |>
+ cor() |>
+ data.frame() |>
+ rownames_to_column("comp_x") |>
+ pivot_longer(
+ cols = starts_with("PC"),
+ names_to = "comp_y", values_to = "correlation"
+ ) |>
+ filter(
+ parse_number(comp_x) <= n_comps,
+ parse_number(comp_y) <= n_comps
+ ) |>
+ ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
geom_tile() +
- geom_text(aes(label = round(correlation,4)), color = "white") +
- labs(title = "Correlation between PCs",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) +
+ geom_text(aes(label = round(correlation, 4)), color = "white") +
+ labs(
+ title = "Correlation between PCs",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) +
coord_equal()
```
@@ -275,10 +329,10 @@ Let's look at the scree plot:
```{r}
#| label: pca-manual-scree
-tibble(eigenvalues) |>
- ggplot(aes(x = seq_along(eigenvalues), y = eigenvalues)) +
+tibble(eigenvalues) |>
+ ggplot(aes(x = seq_along(eigenvalues), y = eigenvalues)) +
geom_hline(yintercept = 1) +
- geom_line(size = 1) +
+ geom_line(linewidth = 1) +
geom_point(size = 3)
```
@@ -290,33 +344,42 @@ Looks identical to the previous one. Let's also look at the correlation matrix b
#| eval: false
data.frame(pc_manual) |>
- rename_with(~ str_glue("PC{parse_number(.x)}")) |>
- rownames_to_column("participant") |>
- pivot_longer(starts_with("PC"), names_to = "prin_comp", values_to = "loading") |>
- filter(parse_number(prin_comp) <= n_comps) |>
- ggplot(aes(x = reorder(prin_comp, parse_number(prin_comp)),
- y = parse_number(participant), fill = loading)) +
- geom_tile() +
- labs(title = "Individual loadings",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "berlin") +
- coord_fixed(1/5)
+ rename_with(~ str_glue("PC{parse_number(.x)}")) |>
+ rownames_to_column("participant") |>
+ pivot_longer(starts_with("PC"),
+ names_to = "prin_comp", values_to = "loading"
+ ) |>
+ filter(parse_number(prin_comp) <= n_comps) |>
+ ggplot(aes(
+ x = reorder(prin_comp, parse_number(prin_comp)),
+ y = parse_number(participant), fill = loading
+ )) +
+ geom_tile() +
+ labs(
+ title = "Individual loadings",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "berlin") +
+ coord_fixed(1 / 5)
```
```{r}
#| label: pca-manual-corr-matrix
-data.frame(pc_manual) |>
- cor() %>%
- round(., 4)
+data.frame(pc_manual) |>
+ cor() |>
+ round(x = _, digits = 4)
```
Yup, also still 0 across the board. Calculating a PCA by just using matrix manipulations isn't too complicated, and it's a fun exercise, but I'd recommend just sticking to the `prcomp()` function, since it's a lot simpler and offer better functionality. Now, let's move on to the independent component analysis.
-
## Independent Component Analysis
+{{{< sidenote br="14em" >}}}
+If you're feeling particularly _mathematical_, you can read find a paper [here](https://www.iiis.org/CDs2017/CD2017Spring/papers/ZA832BA.pdf) that compares different algorithms
+{{{< /sidenote >}}}
+
While PCA attempts to find components explaining the maximum degree of covariance or correlation, an ICA attemps to find components with maximum statistical independence. There's very complicated nuance here where PCA components are orthogonal and uncorrelated to each other and ICA components are merely statistically independent, which is a very subtle nuance. In practice, it'll mean that ICA components also have a practically zero correlation. The main difference is in how the components are obtained. Like with factor analysis, most ICA algorithms require you to provide a number of components up front. The FastICA algorithm we'll use here is a version of an ICA implementation. There's also InfoMax and JADE to name two other implementations. I couldn't tell you the difference between these ICA algorithms. The FastICA is implemented in R through the `fastICA()` function and the eponymous `{fastICA}` package ([link to documentation](https://www.rdocumentation.org/packages/fastICA/versions/1.2-2/topics/fastICA)).
```{r}
@@ -330,18 +393,26 @@ Let's create a weight matrix again. The output from the `fastICA()` doesn't prov
```{r}
#| label: ica-weight-matrix
-ica_weight_matrix <- data.frame(t(ica_model$A)) |>
+ica_weight_matrix <- data.frame(t(ica_model$A)) |>
rename_with(~ str_glue("IC{seq(.)}")) |>
mutate(variable = names(data_features)) |>
- pivot_longer(cols = starts_with("IC"), names_to = "ic", values_to = "loading")
-
-ica_loading_plot <- ggplot(ica_weight_matrix, aes(x = ic, y = variable, fill = loading)) +
- geom_tile() +
- labs(title = "ICA loadings",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) +
- coord_fixed(ratio = 1/2)
+ pivot_longer(
+ cols = starts_with("IC"),
+ names_to = "ic", values_to = "loading"
+ )
+
+ica_loading_plot <- ggplot(
+ ica_weight_matrix,
+ aes(x = ic, y = variable, fill = loading)
+) +
+ geom_tile() +
+ labs(
+ title = "ICA loadings",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) +
+ coord_fixed(ratio = 1 / 2)
print(ica_loading_plot)
```
@@ -353,18 +424,23 @@ Again, we can also visualize the correlation between the different components.
```{r}
#| label: ica-corr-matrix
-ica_model$S |>
- cor() |>
- data.frame() |>
- rownames_to_column("comp_x") |>
- pivot_longer(cols = starts_with("X"), names_to = "comp_y", values_to = "correlation") |>
- ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
+ica_model$S |>
+ cor() |>
+ data.frame() |>
+ rownames_to_column("comp_x") |>
+ pivot_longer(
+ cols = starts_with("X"),
+ names_to = "comp_y", values_to = "correlation"
+ ) |>
+ ggplot(aes(x = comp_x, y = comp_y, fill = correlation)) +
geom_tile() +
- geom_text(aes(label = round(correlation,4)), color = "white") +
- labs(title = "Correlation between ICs",
- x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "berlin", limits = c(-1,1)) +
+ geom_text(aes(label = round(correlation, 4)), color = "white") +
+ labs(
+ title = "Correlation between ICs",
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "berlin", limits = c(-1, 1)) +
coord_equal()
```
@@ -377,32 +453,36 @@ Okay, let's now compare the three approaches and put the loading matrices side b
#| out.width: 100%
all_weight_matrices <- bind_rows(
- fa_weight_matrix |>
- rename(comp = factor) |>
+ fa_weight_matrix |>
+ rename(comp = factor) |>
mutate(alg = "FA"),
- pc_weight_matrix |>
- rename(comp = prin_comp) |>
- mutate(alg = "PCA"),
- ica_weight_matrix |>
- rename(comp = ic) |>
+ pc_weight_matrix |>
+ rename(comp = prin_comp) |>
+ mutate(alg = "PCA"),
+ ica_weight_matrix |>
+ rename(comp = ic) |>
mutate(alg = "ICA")
)
-all_weight_matrices |>
- filter(parse_number(comp) <= n_comps) |>
- mutate(alg = str_glue("{alg} loadings"),
- alg = as_factor(alg)) |>
+all_weight_matrices |>
+ filter(parse_number(comp) <= n_comps) |>
+ mutate(
+ alg = str_glue("{alg} loadings"),
+ alg = as_factor(alg)
+ ) |>
ggplot(aes(x = comp, y = variable, fill = loading)) +
- geom_tile() +
- labs(x = NULL,
- y = NULL) +
- scico::scale_fill_scico(palette = "cork", limits = c(-1,1)) +
- facet_wrap(~ alg, scales = "free_x")
+ geom_tile() +
+ labs(
+ x = NULL,
+ y = NULL
+ ) +
+ scico::scale_fill_scico(palette = "cork", limits = c(-1, 1)) +
+ facet_wrap(~alg, scales = "free_x")
```
Here we can most clearly see the overlap between the three methods, Factor 1, PC1, and IC 6 capture essentially the same information. The same goes for Factor 2, PC2, and IC 4. Other than that we can see that the other components vary quite markedly. I wouldn't be comfortable calling any of the other components "fairly similar" to another. You could see how some variables load together with multiple methods, but then the components those are captured in also have other information or miss information. We already discussed IC7 consisting mostly of a single variable, and a similar thing happens with Factor 4, but for a different variable.
-### BONUS: Hierarchical clustering
+## BONUS: Hierarchical clustering
I'll quickly go over hierarchical clustering too, it's simple and easy to interpret. Hierarchical clustering works by taking your variables and clustering them first into two groups, then three, then four, and so on. It looks at similarity and a concept called "Euclidian distance" (other methods are available) between the variables and determines how to separate. Essentially, hierarchical clustering works by iteratively separating variables into groups until every variable is on its own. It does so rather aggressively, with the previous methods it's possible for a variable to be part of two clusters, with hierarchical clustering it's part of a single cluster only. This approach makes it an easy way to see how variables cluster together at different thresholds.
@@ -437,7 +517,7 @@ The `cutree()` function assigns a cluster to each of the variables. It looks at
```{r}
#| label: dendrogram-w-line
-ggdendro::ggdendrogram(hclust_model) +
+ggdendro::ggdendrogram(hclust_model) +
geom_hline(yintercept = 10.5, color = "firebrick")
```
@@ -446,21 +526,23 @@ Let's look at how the clusters are made up according to the hierarchical cluster
```{r}
#| label: hclust-weight-matrix
-hclust_weight_matrix %>%
- data.frame() |>
- janitor::clean_names() |>
- rename(cluster = x) |>
- rownames_to_column("variable") |>
- ggplot(aes(x = as_factor(cluster), y = variable, fill = as_factor(cluster))) +
- geom_tile() +
- labs(x = NULL,
- y = NULL,
- fill = "cluster") +
+hclust_weight_matrix |>
+ data.frame() |>
+ rename(cluster = hclust_weight_matrix) |>
+ rownames_to_column("variable") |>
+ ggplot(aes(
+ x = as_factor(cluster), y = variable,
+ fill = as_factor(cluster)
+ )) +
+ geom_tile() +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = "cluster"
+ ) +
scico::scale_fill_scico_d(palette = "batlow")
```
We can again see that the same two clusters show up. Cluster 6 and 7 resemble those of Factor 2 and Factor 1, PC2 and PC1, and IC4 and IC6 respectively. If you want to learn more about what you can do with the `hlcust()` and associated functions, you can check out [this webpage](https://uc-r.github.io/hc_clustering).
Okay I'd like to leave it at that. This blogpost is long enough. Again, I had to simplify and take some shortcuts, if you think I made mistakes in that effort, please let me know and I'll fix it as well as I can!
-
-
diff --git a/content/blog/2021-easy-map-norway/areal.csv b/content/blog/2021-easy-map-norway/data/areal.csv
similarity index 100%
rename from content/blog/2021-easy-map-norway/areal.csv
rename to content/blog/2021-easy-map-norway/data/areal.csv
diff --git a/content/blog/2021-easy-map-norway/data/norway_hospitals.rds b/content/blog/2021-easy-map-norway/data/norway_hospitals.rds
new file mode 100644
index 0000000..d13a32c
--- /dev/null
+++ b/content/blog/2021-easy-map-norway/data/norway_hospitals.rds
@@ -0,0 +1,3 @@
+version https://git-lfs.github.com/spec/v1
+oid sha256:10db380d65beafdbc632a6a0ac27d7c714e2a426f5693635726a4f1a929e50ef
+size 601
diff --git a/content/blog/2021-easy-map-norway/splmaps_data.RData b/content/blog/2021-easy-map-norway/data/splmaps_data.RData
similarity index 100%
rename from content/blog/2021-easy-map-norway/splmaps_data.RData
rename to content/blog/2021-easy-map-norway/data/splmaps_data.RData
diff --git a/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/age-plot-1.png b/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/age-plot-1.png
index 03b39ea..6514024 100644
Binary files a/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/age-plot-1.png and b/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/age-plot-1.png differ
diff --git a/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/plot-kommune-faceted-1.png b/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/plot-kommune-faceted-1.png
index f8ce1ce..3e39cf3 100644
Binary files a/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/plot-kommune-faceted-1.png and b/content/blog/2021-easy-map-norway/index.markdown_strict_files/figure-markdown_strict/plot-kommune-faceted-1.png differ
diff --git a/content/blog/2021-easy-map-norway/index.md b/content/blog/2021-easy-map-norway/index.md
index 0249baf..16b83d6 100644
--- a/content/blog/2021-easy-map-norway/index.md
+++ b/content/blog/2021-easy-map-norway/index.md
@@ -9,40 +9,35 @@ tags:
- ggplot
- map
- norway
-editor_options:
- chunk_output_type: console
execute:
fig.retina: 2
fig.align: center
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-
-As of March 2023 {fhimaps} and {splmaps} are no longer supported due to budget cuts at the institution supporting them. The amazing developers (led by Richard Aubrey White and Chi Zhang) have moved the data and functionality to a new package called {csmaps}. The code below is updated to reflect the changes.
-
{fhimaps} and {splmaps} are no longer supported due to budget cuts at the institution supporting them. The amazing developers (led by [Richard Aubrey White](https://www.rwhite.no) and [Chi Zhang](https://andreaczhang.github.io)) have moved the data and functionality to a new package called `{csmaps}`. The code below is updated to reflect the changes.
+{{< /standout >}}
Every now and then you discover a discover a much simpler solution to a problem you spent a lot of time solving. This recently happened to me on the topic of creating a map of Norway in R. In this post, I want to go through the process of what I learned.
Previously, I used a JSON file and the `{geojsonio}` package to create a map of Norway and its fylker (counties) in particular. This was a very flexible and robust way of going about this, but also quite cumbersome. This method relies on a high-quality JSON file, meaning, a file that is detailed enough to display everything nicely, but not too detailed that it takes a ton of time and computing power to create a single plot. While I'll still use this method if I need to create a map for places other than Norway, I think I've found a better and easier solution for plotting Norway and the fylker and kommuner in the [`{csmaps}`](https://www.csids.no/csmaps/) package.
-The `{csmaps}` package is created by the *Consortium for Statistics in Disease Surveillance* team. It's part of a series of packages (which they refer to as the "csverse"), which includes a package containing basic health surveillance data ([`{csdata}`](https://www.csids.no/csdata/)), one for real-time analysis in disease surveillance ([`{sc9}`](https://www.csids.no/sc9/)) and a few more. Here I'll dive into the `{csmaps}` package with some help from the `{csdata}` package. I'll also use the `{ggmap}` package to help with some other data and plotting. It's perhaps important to note that `{ggmap}` does contain a map of Norway as a whole, but not of the fylker and kommuner (municipalities), hence the usefulness of the `{csmaps}` package, which contains both. I'll also use `{tidyverse}` and `{ggtext}` as I always do. I won't load `{csmaps}` with the `library()` function, but will use the `::` operator instead since it'll make it easier to navigate the different datasets included.
+{{< sidenote >}}
+The group has [a bunch of packages](https://www.csids.no) for data science within public health
+{{< /sidenote >}}
+
+The `{csmaps}` package is created by the [*Consortium for Statistics in Disease Surveillance*](https://www.csids.no) team. It's part of a series of packages (which they refer to as the "csverse"), which includes a package containing basic health surveillance data ([`{csdata}`](https://www.csids.no/csdata/)), one for real-time analysis in disease surveillance ([`{sc9}`](https://www.csids.no/sc9/)) and a few more. Here I'll dive into the `{csmaps}` package with some help from the `{csdata}` package. I'll also use the `{ggmap}` package to help with some other data and plotting. It's perhaps important to note that `{ggmap}` does contain a map of Norway as a whole, but not of the fylker and kommuner (municipalities), hence the usefulness of the `{csmaps}` package, which contains both. I'll also use `{tidyverse}` and `{ggtext}` as I always do. I won't load `{csmaps}` with the `library()` function, but will use the `::` operator instead since it'll make it easier to navigate the different datasets included.
``` r
library(tidyverse)
@@ -54,10 +49,10 @@ library(ggmap)
So let's have a look at what's included. You'll see that nearly all maps come in either a `data.table` format or an `sf` format. Here I'll use only the data frames, since they're a lot easier to work with. The maps in `sf` format can be useful elsewhere, but I think for most purposes it's easier and more intuitive to work with data frames.
``` r
-data(package = "csmaps") |>
- pluck("results") |>
- as_tibble() |>
- select(Item, Title) |>
+data(package = "csmaps") |>
+ pluck("results") |>
+ as_tibble() |>
+ select(Item, Title) |>
print(n = 18)
```
@@ -66,22 +61,25 @@ A comprehensive version of this list is also included in the [reference](https:/
So let's have a look at one of those maps. For instance the one with the new fylker from 2020 with an inset of Oslo.
``` r
-map_df <- nor_county_map_b2020_insert_oslo_dt |>
+map_df <- nor_county_map_b2020_insert_oslo_dt |>
glimpse()
```
Rows: 4,493
Columns: 5
- $ long 
@@ -156,12 +179,20 @@ str_glue("Range across latitude: {str_c(range(map_df$lat), collapse = ', ')}")
Let's also combine the map with some actual data. The `{csdata}` package contains some simple data on age distribution in kommuner and fylker. Let's take the data from the different fylker in the last available year and see what proportion of the total population is younger than 18.
``` r
-age_data <- csdata::nor_population_by_age_cats(border = 2020, cats = list(c(0:18))) |>
- filter(str_detect(location_code, "^county"),
- calyear == max(calyear)) |>
- pivot_wider(id_cols = location_code, names_from = age, values_from = pop_jan1_n) |>
+age_data <- csdata::nor_population_by_age_cats(
+ border = 2020,
+ cats = list(seq(18))
+) |>
+ filter(
+ str_detect(location_code, "^county"),
+ calyear == max(calyear)
+ ) |>
+ pivot_wider(
+ id_cols = location_code,
+ names_from = age, values_from = pop_jan1_n
+ ) |>
janitor::clean_names() |>
- rename(age_0_18 = x000_018) |>
+ rename(age_0_18 = x001_018) |>
mutate(proportion = age_0_18 / total)
```
@@ -169,36 +200,60 @@ Let's create a map without the Oslo inset, combine it with the age distribution
``` r
nor_county_map_b2020_default_dt |>
- left_join(age_data, by = "location_code") |>
+ left_join(age_data, by = "location_code") |>
ggplot(aes(x = long, y = lat, group = group)) +
- geom_polygon(data = map_data("world") |> filter(region != "Norway"),
- fill = "grey80") +
- geom_polygon(aes(fill = proportion), key_glyph = "point") +
+ geom_polygon(
+ data = map_data("world") |> filter(region != "Norway"),
+ fill = "grey80"
+ ) +
+ geom_polygon(aes(fill = proportion), key_glyph = "point") +
labs(fill = "Proportion of the population younger than 18") +
- scico::scale_fill_scico(palette = "devon", limits = c(0.15, 0.31),
- labels = scales::percent_format(accuracy = 1),
- guide = guide_colorbar(title.position = "top", title.hjust = 0.5,
- barwidth = 10, barheight = 0.5, ticks = FALSE)) +
- coord_map(projection = "conic", lat0 = 60,
- xlim = c(-8,40), ylim = c(57, 70)) +
+ scico::scale_fill_scico(
+ palette = "devon", limits = c(0.15, 0.31),
+ labels = scales::percent_format(accuracy = 1),
+ guide = guide_colorbar(
+ title.position = "top", title.hjust = 0.5,
+ barwidth = 10, barheight = 0.5, ticks = FALSE
+ )
+ ) +
+ coord_map(
+ projection = "conic", lat0 = 60,
+ xlim = c(-8, 40), ylim = c(57, 70)
+ ) +
theme_void() +
- theme(plot.background = element_rect(fill = "#A2C0F4", color = "transparent"),
- legend.direction = "horizontal",
- legend.position = c(0.8, 0.1),
- legend.title = element_text(size = 8),
- legend.text = element_text(size = 6))
+ theme(
+ plot.background = element_rect(
+ fill = "#A2C0F4",
+ color = "transparent"
+ ),
+ legend.direction = "horizontal",
+ legend.position = c(0.8, 0.1),
+ legend.title = element_text(size = 8),
+ legend.text = element_text(size = 6)
+ )
```
## Geocoding
+{{< sidenote br="3em" >}}
+The Google Maps API requires a personal API key, you can read how to obtain and register an API key [here](https://github.com/dkahle/ggmap)
+{{< /sidenote >}}
+
The `{ggmap}` package also has an incredibly useful function called `mutate_geocode()` which transforms a string with an address or description in character format to longitude and latitude. Since `{ggmap}` uses the Google Maps API, it works similarly to typing in a description in Google Maps. So an approximation of the location will (most likely) get you the right result (e.g. with "Hospital Lillehammer"). Note that `mutate_geocode` uses `lon` instead of `long` as column name for longitude. Just to avoid confusion, I'll rename the column to `long`.
``` r
-hospitals_df <- tibble(location = c("Ullevål Sykehus, Oslo","Haukeland universitetssjukehus, Bergen","St. Olav, Trondheim",
- "Universitetssykehuset Nord-Norge, Tromsø","Stavanger Universitetssjukehus","Sørlandet Hospital Kristiansand", "Hospital Lillehammer")) |>
- mutate_geocode(location) |>
+hospitals_df <- tibble(location = c(
+ "Ullevål Sykehus, Oslo",
+ "Haukeland universitetssjukehus, Bergen",
+ "St. Olav, Trondheim",
+ "Universitetssykehuset Nord-Norge, Tromsø",
+ "Stavanger Universitetssjukehus",
+ "Sørlandet Hospital Kristiansand",
+ "Hospital Lillehammer"
+)) |>
+ mutate_geocode(location) |>
rename(long = lon)
```
@@ -224,27 +279,47 @@ Now let's put these on top of the map. We'll use the same map we used earlier. W
``` r
set.seed(21)
-map_df |>
- left_join(county_names, by = "location_code") |>
- ggplot(aes(x = long, y = lat, fill = location_name, group = group)) +
- geom_polygon(key_glyph = "point") +
- geom_segment(data = hospitals_df |> filter(str_detect(location, "Oslo")),
- aes(x = long, y = lat, xend = 19.5, yend = 62), inherit.aes = FALSE) +
- geom_point(data = hospitals_df, aes(x = long, y = lat), inherit.aes = FALSE,
- shape = 18, color = "firebrick", size = 4, show.legend = FALSE) +
- ggrepel::geom_label_repel(data = hospitals_df, aes(x = long, y = lat, label = location),
- size = 2, alpha = 0.75, label.size = 0, inherit.aes = FALSE) +
- labs(x = NULL,
- y = NULL,
- fill = NULL) +
- scale_fill_manual(values = county_colors,
- guide = guide_legend(override.aes = list(size = 4, shape = 21,
- color = "transparent"))) +
- coord_map(projection = "conic", lat0 = 60) +
+map_df |>
+ left_join(county_names, by = "location_code") |>
+ ggplot(aes(
+ x = long, y = lat,
+ fill = location_name, group = group
+ )) +
+ geom_polygon(key_glyph = "point") +
+ geom_segment(
+ data = hospitals_df |> filter(str_detect(location, "Oslo")),
+ aes(x = long, y = lat, xend = 19.5, yend = 62),
+ inherit.aes = FALSE
+ ) +
+ geom_point(
+ data = hospitals_df, aes(x = long, y = lat),
+ inherit.aes = FALSE,
+ shape = 18, color = "firebrick",
+ size = 4, show.legend = FALSE
+ ) +
+ ggrepel::geom_label_repel(
+ data = hospitals_df, aes(x = long, y = lat, label = location),
+ size = 2, alpha = 0.75, label.size = 0, inherit.aes = FALSE
+ ) +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = NULL
+ ) +
+ scale_fill_manual(
+ values = county_colors,
+ guide = guide_legend(override.aes = list(
+ size = 4, shape = 21,
+ color = "transparent"
+ ))
+ ) +
+ coord_map(projection = "conic", lat0 = 60) +
theme_void() +
- theme(legend.position = c(0.2,0.7),
- legend.text = element_text(size = 5),
- legend.key.height = unit(10,"pt"))
+ theme(
+ legend.position = c(0.2, 0.7),
+ legend.text = element_text(size = 5),
+ legend.key.height = unit(10, "pt")
+ )
```
@@ -254,97 +329,125 @@ map_df |>
Let's take it a step further and now look at how we can combine our map with data that didn't come directly from the FHI. Instead I downloaded some data from the Norwegian Statistics Bureau ([Statistisk sentralbyrå, SSB](https://www.ssb.no)) on land use in the kommuner ([link](https://www.ssb.no/en/natur-og-miljo/areal/statistikk/arealbruk-og-arealressurser)). This came in the form of a semi-colon separated .csv file.
``` r
-area_use <- read_delim("areal.csv", delim = ";", skip = 2) |>
+area_use <- read_delim("./data/areal.csv",
+ delim = ";", skip = 2
+) |>
janitor::clean_names()
print(area_use)
```
# A tibble: 356 × 20
- region area_2021_residential_areas area_2021_recreational_facilities area_2021_built_up_areas_for_agriculture_and_fishing area_2021_industrial_commercial_and_service_areas area_2021_education_and_day_care_facilities area_2021_health_and_social_welfare_institutions area_2021_cultural_and_religious_activities area_2021_transport_telecommunications_and_technical_infrastructure area_2021_emergency_and_defence_services area_2021_green_areas_and_sports_facilities area_2021_unclassified_built_up_areas_and_related_land area_2021_agricultural_land area_2021_forest area_2021_open_firm_ground area_2021_wetland area_2021_bare_rock_gravel_and_blockfields area_2021_permanent_snow_and_glaciers area_2021_inland_waters area_2021_unclassified_undeveloped_areas
- 
@@ -353,45 +456,53 @@ nor_municip_map_b2020_split_dt |>
The last thing I want to show is a map of Oslo! `{csmaps}` contains a detailed map of the bydeler that we will use. Now, these bydeler are again coded and `{csdata}` (since it's update) now contains a [data frame](https://www.csids.no/csmaps/articles/customization.html#add-location-name-for-ward-and-population-for-oslo-map) with the corresponding names for all geography levels (fylker, municipalities, bydeler, etc.). We could get our data from there, but we also need something to visualize so we'll scrape a Wikipedia article for Oslo's bydeler which contains a table with the bydel numbers, the names, and some data we can use for visualization. We'll extract the table from the website using `{rvest}`, do some data wrangling and prepare it for merging into the data frame with the map. I won't go into the wrangling much here, we're interested mainly in the plotting of the data right now.
+{{< sidenote >}}
+I won't go into much detail on web scraping here, you can see one of the [other posts](https://danielroelfs.com/blog/) for more details
+{{< /sidenote >}}
+
``` r
-bydel_data <- "https://en.wikipedia.org/wiki/List_of_boroughs_of_Oslo" |>
- rvest::read_html() |>
- rvest::html_table() |>
- pluck(1) |>
- janitor::clean_names() |>
- mutate(inhabitants = str_remove_all(residents, "[[:blank:]]"),
- inhabitants = as.numeric(inhabitants),
- area = str_remove_all(area, "km2"),
- area = str_replace_all(area, ",", "."),
- area = str_squish(area),
- area = as.numeric(area),
- pop_density = inhabitants / area) |>
- arrange(number) |>
- mutate(bydel_nr = format(number, digits = 2),
- bydel_nr = str_replace_all(bydel_nr, " ", "0"),
- location_code = str_glue("wardoslo_nor0301{bydel_nr}"))
+bydel_data <- "https://en.wikipedia.org/wiki/List_of_boroughs_of_Oslo" |>
+ rvest::read_html() |>
+ rvest::html_table() |>
+ pluck(1) |>
+ janitor::clean_names() |>
+ mutate(
+ inhabitants = str_remove_all(residents, "[[:blank:]]"),
+ inhabitants = as.numeric(inhabitants),
+ area = str_remove_all(area, "km2"),
+ area = str_replace_all(area, ",", "."),
+ area = str_squish(area),
+ area = as.numeric(area),
+ pop_density = inhabitants / area
+ ) |>
+ arrange(number) |>
+ mutate(
+ bydel_nr = format(number, digits = 2),
+ bydel_nr = str_replace_all(bydel_nr, " ", "0"),
+ location_code = str_glue("wardoslo_nor0301{bydel_nr}")
+ )
print(bydel_data)
```
# A tibble: 15 × 8
- borough residents area number inhabitants pop_density bydel_nr location_code
- 
@@ -429,11 +555,11 @@ An example of when you might use the `sf` data format is in interactive maps. He
library(leaflet)
map_sf <- csmaps::nor_county_map_b2020_default_sf |>
- sf::st_as_sf() |>
+ sf::st_as_sf() |>
left_join(county_names, by = "location_code")
-map_sf |>
- leaflet() |>
+map_sf |>
+ leaflet() |>
addProviderTiles(providers$Esri.WorldStreetMap) |>
addPolygons(
fillColor = unname(county_colors),
@@ -442,7 +568,8 @@ map_sf |>
fillOpacity = 0.75,
highlightOptions = highlightOptions(
color = "#333", bringToFront = TRUE,
- weight = 2, opacity = 1)
+ weight = 2, opacity = 1
+ )
)
```
@@ -453,3 +580,7 @@ map_sf |>
In addition, I also replaced all usage of the NORMENT internal `{normentR}` package with the `{scico}` package which is available on CRAN.
**EDIT (2023-06-18)**: Updated the blogpost to reflect the deprecation of the `{splmaps}` and `{spldata}` packages. Replaced them with the replacement package `{csmaps}` available on CRAN.
+
+
+
+
diff --git a/content/blog/2021-easy-map-norway/index.qmd b/content/blog/2021-easy-map-norway/index.qmd
index c52efc6..efd2443 100644
--- a/content/blog/2021-easy-map-norway/index.qmd
+++ b/content/blog/2021-easy-map-norway/index.qmd
@@ -9,52 +9,38 @@ tags:
- ggplot
- map
- norway
-editor_options:
- chunk_output_type: console
execute:
fig.retina: 2
fig.align: center
fig.show: hold
results: hold
out.width: 80%
+editor_options:
+ chunk_output_type: console
---
-
```{css}
#| label: style
#| echo: FALSE
-p.announcement {
- border-radius: 5px;
- background-color: #acc8d4;
- padding: 1em;
-}
-
-p.announcement code {
+p.stand-out-paragraph code {
background-color: #93b8c8;
}
```
-
-As of March 2023 {fhimaps} and {splmaps} are no longer supported due to budget cuts at the institution supporting them. The amazing developers (led by Richard Aubrey White and Chi Zhang) have moved the data and functionality to a new package called {csmaps}. The code below is updated to reflect the changes.
-
{fhimaps} and {splmaps} are no longer supported due to budget cuts at the institution supporting them. The amazing developers (led by [Richard Aubrey White](https://www.rwhite.no) and [Chi Zhang](https://andreaczhang.github.io)) have moved the data and functionality to a new package called `{csmaps}`. The code below is updated to reflect the changes.
+{{{< /standout >}}}
Every now and then you discover a discover a much simpler solution to a problem you spent a lot of time solving. This recently happened to me on the topic of creating a map of Norway in R. In this post, I want to go through the process of what I learned.
Previously, I used a JSON file and the `{geojsonio}` package to create a map of Norway and its fylker (counties) in particular. This was a very flexible and robust way of going about this, but also quite cumbersome. This method relies on a high-quality JSON file, meaning, a file that is detailed enough to display everything nicely, but not too detailed that it takes a ton of time and computing power to create a single plot. While I'll still use this method if I need to create a map for places other than Norway, I think I've found a better and easier solution for plotting Norway and the fylker and kommuner in the [`{csmaps}`](https://www.csids.no/csmaps/) package.
-The `{csmaps}` package is created by the _Consortium for Statistics in Disease Surveillance_ team. It's part of a series of packages (which they refer to as the "csverse"), which includes a package containing basic health surveillance data ([`{csdata}`](https://www.csids.no/csdata/)), one for real-time analysis in disease surveillance ([`{sc9}`](https://www.csids.no/sc9/)) and a few more. Here I'll dive into the `{csmaps}` package with some help from the `{csdata}` package. I'll also use the `{ggmap}` package to help with some other data and plotting. It's perhaps important to note that `{ggmap}` does contain a map of Norway as a whole, but not of the fylker and kommuner (municipalities), hence the usefulness of the `{csmaps}` package, which contains both. I'll also use `{tidyverse}` and `{ggtext}` as I always do. I won't load `{csmaps}` with the `library()` function, but will use the `::` operator instead since it'll make it easier to navigate the different datasets included.
+{{{< sidenote >}}}
+The group has [a bunch of packages](https://www.csids.no) for data science within public health
+{{{< /sidenote >}}}
+
+The `{csmaps}` package is created by the [_Consortium for Statistics in Disease Surveillance_](https://www.csids.no) team. It's part of a series of packages (which they refer to as the "csverse"), which includes a package containing basic health surveillance data ([`{csdata}`](https://www.csids.no/csdata/)), one for real-time analysis in disease surveillance ([`{sc9}`](https://www.csids.no/sc9/)) and a few more. Here I'll dive into the `{csmaps}` package with some help from the `{csdata}` package. I'll also use the `{ggmap}` package to help with some other data and plotting. It's perhaps important to note that `{ggmap}` does contain a map of Norway as a whole, but not of the fylker and kommuner (municipalities), hence the usefulness of the `{csmaps}` package, which contains both. I'll also use `{tidyverse}` and `{ggtext}` as I always do. I won't load `{csmaps}` with the `library()` function, but will use the `::` operator instead since it'll make it easier to navigate the different datasets included.
```{r}
#| label: pkgs
@@ -72,10 +58,10 @@ So let's have a look at what's included. You'll see that nearly all maps come in
#| label: print-map-list
#| eval: false
-data(package = "csmaps") |>
- pluck("results") |>
- as_tibble() |>
- select(Item, Title) |>
+data(package = "csmaps") |>
+ pluck("results") |>
+ as_tibble() |>
+ select(Item, Title) |>
print(n = 18)
```
@@ -86,7 +72,7 @@ So let's have a look at one of those maps. For instance the one with the new fyl
```{r}
#| label: load-map
-map_df <- nor_county_map_b2020_insert_oslo_dt |>
+map_df <- nor_county_map_b2020_insert_oslo_dt |>
glimpse()
```
@@ -95,7 +81,10 @@ Immediately you can see that there's a lot of rows, each representing a point on
```{r}
#| label: minimal-plot
-ggplot(map_df, aes(x = long, y = lat, group = group, fill = location_code)) +
+ggplot(map_df, aes(
+ x = long, y = lat,
+ group = group, fill = location_code
+)) +
geom_polygon()
```
@@ -104,21 +93,30 @@ Now let's convert the awkward county numbers to the actual names of the fylker.
```{r}
#| label: fylke-names
-county_names <- csdata::nor_locations_names(border = 2020) |>
+county_names <- csdata::nor_locations_names(border = 2020) |>
filter(str_detect(location_code, "^county")) |>
distinct(location_code, location_name)
print(county_names)
```
-Now let's also create a nice color palette to give each fylke a nicer color than the default ggplot colors. We'll create a named vector to match each fylke with a color from the _batlow_ palette by [Fabio Crameri](https://www.fabiocrameri.ch/colourmaps/).
+{{{< sidenote >}}}
+The [`{scico}`](https://github.com/thomasp85/scico) package contains a collection of color palettes that are great for accessibility
+{{{< /sidenote >}}}
+
+Now let's also create a nice color palette to give each fylke a nicer color than the default ggplot colors. We'll create a named vector to match each fylke with a color from the _batlow_ palette by [Fabio Crameri](https://www.fabiocrameri.ch/colourmaps/) implemented in the `{scico}` package.
```{r}
#| label: fylke-colors
#| message: false
-county_colors <- setNames(scico::scico(n = nrow(county_names), palette = "batlow"),
- nm = county_names$location_name)
+county_colors <- setNames(
+ scico::scico(
+ n = nrow(county_names),
+ palette = "batlow"
+ ),
+ nm = county_names$location_name
+)
```
Let's see what we can make now. We'll add the county names to the large data frame containing the longitudes and latitudes and then create a plot again. I'll also add some other style elements, such as a labels to the x- and y-axes, circles instead of squares for the legend and a map projection. For Norway especially I think a conic map projection works well since the northern fylker are so massive and the southern fylker are more dense, so adding a conic projection with a cone tangent of 40 degrees makes it a bit more perceptionally balanced (`lat0` refers to the cone tangent, the details are complicated but a higher cone tangent results a greater distortion in favor of southern points).
@@ -126,23 +124,39 @@ Let's see what we can make now. We'll add the county names to the large data fra
```{r}
#| label: simple-plot
-map_df |>
- left_join(county_names, by = "location_code") |>
- ggplot(aes(x = long, y = lat, fill = location_name, group = group)) +
- geom_polygon(key_glyph = "point") +
- labs(x = NULL,
- y = NULL,
- fill = NULL) +
- scale_x_continuous(labels = scales::label_number(suffix = "\u00b0W")) +
- scale_y_continuous(labels = scales::label_number(suffix = "\u00b0N")) +
- scale_fill_manual(values = county_colors,
- guide = guide_legend(override.aes = list(shape = 21, size = 4))) +
- coord_map(projection = "conic", lat0 = 40) +
+map_df |>
+ left_join(county_names, by = "location_code") |>
+ ggplot(aes(
+ x = long, y = lat,
+ fill = location_name, group = group
+ )) +
+ geom_polygon(key_glyph = "point") +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = NULL
+ ) +
+ scale_x_continuous(
+ labels = scales::label_number(suffix = "\u00b0W")
+ ) +
+ scale_y_continuous(
+ labels = scales::label_number(suffix = "\u00b0N")
+ ) +
+ scale_fill_manual(
+ values = county_colors,
+ guide = guide_legend(override.aes = list(shape = 21, size = 4))
+ ) +
+ coord_map(projection = "conic", lat0 = 40) +
theme_minimal() +
- theme(legend.position = c(0.9,0.2),
- legend.text = element_text(size = 5),
- legend.key.height = unit(10,"pt"),
- legend.background = element_rect(fill = "white", color = "transparent"))
+ theme(
+ legend.position = c(0.9, 0.2),
+ legend.text = element_text(size = 5),
+ legend.key.height = unit(10, "pt"),
+ legend.background = element_rect(
+ fill = "white",
+ color = "transparent"
+ )
+ )
```
## Norway with Scandinavia
@@ -162,12 +176,20 @@ Let's also combine the map with some actual data. The `{csdata}` package contain
```{r}
#| label: get-age-data
-age_data <- csdata::nor_population_by_age_cats(border = 2020, cats = list(c(0:18))) |>
- filter(str_detect(location_code, "^county"),
- calyear == max(calyear)) |>
- pivot_wider(id_cols = location_code, names_from = age, values_from = pop_jan1_n) |>
+age_data <- csdata::nor_population_by_age_cats(
+ border = 2020,
+ cats = list(seq(18))
+) |>
+ filter(
+ str_detect(location_code, "^county"),
+ calyear == max(calyear)
+ ) |>
+ pivot_wider(
+ id_cols = location_code,
+ names_from = age, values_from = pop_jan1_n
+ ) |>
janitor::clean_names() |>
- rename(age_0_18 = x000_018) |>
+ rename(age_0_18 = x001_018) |>
mutate(proportion = age_0_18 / total)
```
@@ -177,37 +199,61 @@ Let's create a map without the Oslo inset, combine it with the age distribution
#| label: age-plot
nor_county_map_b2020_default_dt |>
- left_join(age_data, by = "location_code") |>
+ left_join(age_data, by = "location_code") |>
ggplot(aes(x = long, y = lat, group = group)) +
- geom_polygon(data = map_data("world") |> filter(region != "Norway"),
- fill = "grey80") +
- geom_polygon(aes(fill = proportion), key_glyph = "point") +
+ geom_polygon(
+ data = map_data("world") |> filter(region != "Norway"),
+ fill = "grey80"
+ ) +
+ geom_polygon(aes(fill = proportion), key_glyph = "point") +
labs(fill = "Proportion of the population younger than 18") +
- scico::scale_fill_scico(palette = "devon", limits = c(0.15, 0.31),
- labels = scales::percent_format(accuracy = 1),
- guide = guide_colorbar(title.position = "top", title.hjust = 0.5,
- barwidth = 10, barheight = 0.5, ticks = FALSE)) +
- coord_map(projection = "conic", lat0 = 60,
- xlim = c(-8,40), ylim = c(57, 70)) +
+ scico::scale_fill_scico(
+ palette = "devon", limits = c(0.15, 0.31),
+ labels = scales::percent_format(accuracy = 1),
+ guide = guide_colorbar(
+ title.position = "top", title.hjust = 0.5,
+ barwidth = 10, barheight = 0.5, ticks = FALSE
+ )
+ ) +
+ coord_map(
+ projection = "conic", lat0 = 60,
+ xlim = c(-8, 40), ylim = c(57, 70)
+ ) +
theme_void() +
- theme(plot.background = element_rect(fill = "#A2C0F4", color = "transparent"),
- legend.direction = "horizontal",
- legend.position = c(0.8, 0.1),
- legend.title = element_text(size = 8),
- legend.text = element_text(size = 6))
+ theme(
+ plot.background = element_rect(
+ fill = "#A2C0F4",
+ color = "transparent"
+ ),
+ legend.direction = "horizontal",
+ legend.position = c(0.8, 0.1),
+ legend.title = element_text(size = 8),
+ legend.text = element_text(size = 6)
+ )
```
## Geocoding
+{{{< sidenote br="3em" >}}}
+The Google Maps API requires a personal API key, you can read how to obtain and register an API key [here](https://github.com/dkahle/ggmap)
+{{{< /sidenote >}}}
+
The `{ggmap}` package also has an incredibly useful function called `mutate_geocode()` which transforms a string with an address or description in character format to longitude and latitude. Since `{ggmap}` uses the Google Maps API, it works similarly to typing in a description in Google Maps. So an approximation of the location will (most likely) get you the right result (e.g. with "Hospital Lillehammer"). Note that `mutate_geocode` uses `lon` instead of `long` as column name for longitude. Just to avoid confusion, I'll rename the column to `long`.
```{r}
#| label: get-cities-locations
#| eval: false
-hospitals_df <- tibble(location = c("Ullevål Sykehus, Oslo","Haukeland universitetssjukehus, Bergen","St. Olav, Trondheim",
- "Universitetssykehuset Nord-Norge, Tromsø","Stavanger Universitetssjukehus","Sørlandet Hospital Kristiansand", "Hospital Lillehammer")) |>
- mutate_geocode(location) |>
+hospitals_df <- tibble(location = c(
+ "Ullevål Sykehus, Oslo",
+ "Haukeland universitetssjukehus, Bergen",
+ "St. Olav, Trondheim",
+ "Universitetssykehuset Nord-Norge, Tromsø",
+ "Stavanger Universitetssjukehus",
+ "Sørlandet Hospital Kristiansand",
+ "Hospital Lillehammer"
+)) |>
+ mutate_geocode(location) |>
rename(long = lon)
```
@@ -216,14 +262,14 @@ hospitals_df <- tibble(location = c("Ullevål Sykehus, Oslo","Haukeland universi
#| echo: false
#| eval: false
-write_rds(hospitals_df, "norway_hospitals.rds")
+write_rds(hospitals_df, "./data/norway_hospitals.rds")
```
```{r}
#| label: load-cities-geo
#| echo: false
-hospitals_df <- read_rds("norway_hospitals.rds")
+hospitals_df <- read_rds("./data/norway_hospitals.rds")
```
This is the list of coordinates it gave us:
@@ -241,27 +287,47 @@ Now let's put these on top of the map. We'll use the same map we used earlier. W
set.seed(21)
-map_df |>
- left_join(county_names, by = "location_code") |>
- ggplot(aes(x = long, y = lat, fill = location_name, group = group)) +
- geom_polygon(key_glyph = "point") +
- geom_segment(data = hospitals_df |> filter(str_detect(location, "Oslo")),
- aes(x = long, y = lat, xend = 19.5, yend = 62), inherit.aes = FALSE) +
- geom_point(data = hospitals_df, aes(x = long, y = lat), inherit.aes = FALSE,
- shape = 18, color = "firebrick", size = 4, show.legend = FALSE) +
- ggrepel::geom_label_repel(data = hospitals_df, aes(x = long, y = lat, label = location),
- size = 2, alpha = 0.75, label.size = 0, inherit.aes = FALSE) +
- labs(x = NULL,
- y = NULL,
- fill = NULL) +
- scale_fill_manual(values = county_colors,
- guide = guide_legend(override.aes = list(size = 4, shape = 21,
- color = "transparent"))) +
- coord_map(projection = "conic", lat0 = 60) +
+map_df |>
+ left_join(county_names, by = "location_code") |>
+ ggplot(aes(
+ x = long, y = lat,
+ fill = location_name, group = group
+ )) +
+ geom_polygon(key_glyph = "point") +
+ geom_segment(
+ data = hospitals_df |> filter(str_detect(location, "Oslo")),
+ aes(x = long, y = lat, xend = 19.5, yend = 62),
+ inherit.aes = FALSE
+ ) +
+ geom_point(
+ data = hospitals_df, aes(x = long, y = lat),
+ inherit.aes = FALSE,
+ shape = 18, color = "firebrick",
+ size = 4, show.legend = FALSE
+ ) +
+ ggrepel::geom_label_repel(
+ data = hospitals_df, aes(x = long, y = lat, label = location),
+ size = 2, alpha = 0.75, label.size = 0, inherit.aes = FALSE
+ ) +
+ labs(
+ x = NULL,
+ y = NULL,
+ fill = NULL
+ ) +
+ scale_fill_manual(
+ values = county_colors,
+ guide = guide_legend(override.aes = list(
+ size = 4, shape = 21,
+ color = "transparent"
+ ))
+ ) +
+ coord_map(projection = "conic", lat0 = 60) +
theme_void() +
- theme(legend.position = c(0.2,0.7),
- legend.text = element_text(size = 5),
- legend.key.height = unit(10,"pt"))
+ theme(
+ legend.position = c(0.2, 0.7),
+ legend.text = element_text(size = 5),
+ legend.key.height = unit(10, "pt")
+ )
```
@@ -273,7 +339,9 @@ Let's take it a step further and now look at how we can combine our map with dat
#| label: load-area-use
#| message: false
-area_use <- read_delim("areal.csv", delim = ";", skip = 2) |>
+area_use <- read_delim("./data/areal.csv",
+ delim = ";", skip = 2
+) |>
janitor::clean_names()
print(area_use)
@@ -284,17 +352,19 @@ You can see there's 356 rows, each representing a different kommune in Norway. T
```{r}
#| label: wrangle-area-use
-area_use <- area_use |>
- mutate(total_area = rowSums(across(where(is.numeric))),
- kommune_code = parse_number(region),
- kommune_code = format(kommune_code, digits = 4),
- kommune_code = str_replace_all(kommune_code, " ", "0"),
- location_code = str_glue("municip_nor{kommune_code}"),
- perc_rocks = area_2021_bare_rock_gravel_and_blockfields / total_area,
- perc_wetland = area_2021_wetland / total_area,
- perc_forest = area_2021_forest / total_area,
- perc_open_ground = area_2021_open_firm_ground / total_area) |>
- arrange(kommune_code) |>
+area_use <- area_use |>
+ mutate(
+ total_area = rowSums(across(where(is.numeric))),
+ kommune_code = parse_number(region),
+ kommune_code = format(kommune_code, digits = 4),
+ kommune_code = str_replace_all(kommune_code, " ", "0"),
+ location_code = str_glue("municip_nor{kommune_code}"),
+ perc_rocks = area_2021_bare_rock_gravel_and_blockfields / total_area,
+ perc_wetland = area_2021_wetland / total_area,
+ perc_forest = area_2021_forest / total_area,
+ perc_open_ground = area_2021_open_firm_ground / total_area
+ ) |>
+ arrange(kommune_code) |>
glimpse()
```
@@ -303,51 +373,77 @@ Then the next step is very similar to what we've done before. We'll use `left_jo
```{r}
#| label: plot-kommune-faceted
-nor_municip_map_b2020_split_dt |>
- left_join(area_use, by = "location_code") |>
- pivot_longer(cols = starts_with("perc"), names_to = "land_type", values_to = "percentage") |>
- mutate(land_type_label = case_when(str_detect(land_type, "rocks") ~ "Bare rock, gravel and rockfields",
- str_detect(land_type, "wetland") ~ "Wetland",
- str_detect(land_type, "forest") ~ "Forest",
- str_detect(land_type, "open_ground") ~ "Open firm ground")) |>
- ggplot(aes(x = long, y = lat, group = group, fill = percentage)) +
- geom_polygon() +
+nor_municip_map_b2020_split_dt |>
+ left_join(area_use, by = "location_code") |>
+ pivot_longer(
+ cols = starts_with("perc"),
+ names_to = "land_type", values_to = "percentage"
+ ) |>
+ mutate(land_type_label = case_when(
+ str_detect(land_type, "rocks") ~ "Bare rock, gravel and rockfields",
+ str_detect(land_type, "wetland") ~ "Wetland",
+ str_detect(land_type, "forest") ~ "Forest",
+ str_detect(land_type, "open_ground") ~ "Open firm ground"
+ )) |>
+ ggplot(aes(
+ x = long, y = lat,
+ group = group, fill = percentage
+ )) +
+ geom_polygon() +
labs(fill = "Percentage") +
- scico::scale_fill_scico(palette = "acton", labels = scales::label_percent(), limits = c(0,1),
- guide = guide_colorbar(barheight = 0.5, barwidth = 12,
- ticks = FALSE, direction = "horizontal",
- title.position = "top", title.hjust = 0.5)) +
- facet_wrap(~ land_type_label) +
- coord_map(projection = "conic", lat0 = 60) +
+ scico::scale_fill_scico(
+ palette = "acton",
+ labels = scales::label_percent(),
+ limits = c(0, 1),
+ guide = guide_colorbar(
+ barheight = 0.5, barwidth = 12,
+ ticks = FALSE, direction = "horizontal",
+ title.position = "top", title.hjust = 0.5
+ )
+ ) +
+ facet_wrap(~land_type_label) +
+ coord_map(projection = "conic", lat0 = 60) +
theme_void() +
- theme(legend.position = "bottom",
- strip.text.x = element_textbox_simple(size = rel(1.25), halign = 0.5,
- margin = margin(10,0,10,0, "pt")))
+ theme(
+ legend.position = "bottom",
+ strip.text.x = element_textbox_simple(
+ size = rel(1.25), halign = 0.5,
+ margin = margin(10, 0, 10, 0, "pt")
+ )
+ )
```
## Oslo
The last thing I want to show is a map of Oslo! `{csmaps}` contains a detailed map of the bydeler that we will use. Now, these bydeler are again coded and `{csdata}` (since it's update) now contains a [data frame](https://www.csids.no/csmaps/articles/customization.html#add-location-name-for-ward-and-population-for-oslo-map) with the corresponding names for all geography levels (fylker, municipalities, bydeler, etc.). We could get our data from there, but we also need something to visualize so we'll scrape a Wikipedia article for Oslo's bydeler which contains a table with the bydel numbers, the names, and some data we can use for visualization. We'll extract the table from the website using `{rvest}`, do some data wrangling and prepare it for merging into the data frame with the map. I won't go into the wrangling much here, we're interested mainly in the plotting of the data right now.
+{{{< sidenote >}}}
+I won't go into much detail on web scraping here, you can see one of the [other posts](https://danielroelfs.com/blog/) for more details
+{{{< /sidenote >}}}
+
```{r}
#| label: scrape-bydel-names
-bydel_data <- "https://en.wikipedia.org/wiki/List_of_boroughs_of_Oslo" |>
- rvest::read_html() |>
- rvest::html_table() |>
- pluck(1) |>
- janitor::clean_names() |>
- mutate(inhabitants = str_remove_all(residents, "[[:blank:]]"),
- inhabitants = as.numeric(inhabitants),
- area = str_remove_all(area, "km2"),
- area = str_replace_all(area, ",", "."),
- area = str_squish(area),
- area = as.numeric(area),
- pop_density = inhabitants / area) |>
- arrange(number) |>
- mutate(bydel_nr = format(number, digits = 2),
- bydel_nr = str_replace_all(bydel_nr, " ", "0"),
- location_code = str_glue("wardoslo_nor0301{bydel_nr}"))
+bydel_data <- "https://en.wikipedia.org/wiki/List_of_boroughs_of_Oslo" |>
+ rvest::read_html() |>
+ rvest::html_table() |>
+ pluck(1) |>
+ janitor::clean_names() |>
+ mutate(
+ inhabitants = str_remove_all(residents, "[[:blank:]]"),
+ inhabitants = as.numeric(inhabitants),
+ area = str_remove_all(area, "km2"),
+ area = str_replace_all(area, ",", "."),
+ area = str_squish(area),
+ area = as.numeric(area),
+ pop_density = inhabitants / area
+ ) |>
+ arrange(number) |>
+ mutate(
+ bydel_nr = format(number, digits = 2),
+ bydel_nr = str_replace_all(bydel_nr, " ", "0"),
+ location_code = str_glue("wardoslo_nor0301{bydel_nr}")
+ )
print(bydel_data)
```
@@ -367,19 +463,34 @@ Then we'll create the final plot. This will be more-or-less identical to what we
#| label: plot-oslo
oslo_ward_map_b2020_default_dt |>
- left_join(bydel_data, by = "location_code") |>
+ left_join(bydel_data, by = "location_code") |>
ggplot(aes(x = long, y = lat, group = group)) +
- geom_polygon(aes(color = pop_density, fill = pop_density)) +
- geom_label(data = bydel_centres, aes(label = borough, group = 1), alpha = 0.5, label.size = 0) +
- labs(fill = "No of inhabitants per km2") +
- scico::scale_color_scico(palette = "turku", limits = c(0,1.5e4), guide = "none") +
- scico::scale_fill_scico(palette = "turku", limits = c(0,1.5e4), labels = scales::number_format(),
- guide = guide_colorbar(title.position = "top", title.hjust = 0.5,
- barwidth = 15, barheight = 0.75, ticks = FALSE)) +
- theme_void() +
- theme(legend.position = "bottom",
- legend.title = element_markdown(),
- legend.direction = "horizontal")
+ geom_polygon(aes(color = pop_density, fill = pop_density)) +
+ geom_label(
+ data = bydel_centres, aes(label = borough, group = 1),
+ alpha = 0.5, label.size = 0
+ ) +
+ labs(fill = "No of inhabitants per km2") +
+ scico::scale_color_scico(
+ palette = "turku",
+ limits = c(0, 1.5e4),
+ guide = "none"
+ ) +
+ scico::scale_fill_scico(
+ palette = "turku",
+ limits = c(0, 1.5e4),
+ labels = scales::number_format(),
+ guide = guide_colorbar(
+ title.position = "top", title.hjust = 0.5,
+ barwidth = 15, barheight = 0.75, ticks = FALSE
+ )
+ ) +
+ theme_void() +
+ theme(
+ legend.position = "bottom",
+ legend.title = element_markdown(),
+ legend.direction = "horizontal"
+ )
```
@@ -394,11 +505,11 @@ An example of when you might use the `sf` data format is in interactive maps. He
library(leaflet)
map_sf <- csmaps::nor_county_map_b2020_default_sf |>
- sf::st_as_sf() |>
+ sf::st_as_sf() |>
left_join(county_names, by = "location_code")
-map_sf |>
- leaflet() |>
+map_sf |>
+ leaflet() |>
addProviderTiles(providers$Esri.WorldStreetMap) |>
addPolygons(
fillColor = unname(county_colors),
@@ -407,7 +518,8 @@ map_sf |>
fillOpacity = 0.75,
highlightOptions = highlightOptions(
color = "#333", bringToFront = TRUE,
- weight = 2, opacity = 1)
+ weight = 2, opacity = 1
+ )
)
```
@@ -416,8 +528,8 @@ map_sf |>
#| echo: false
#| eval: false
-map <- map_sf |>
- leaflet() |>
+map <- map_sf |>
+ leaflet() |>
addProviderTiles(providers$Esri.WorldStreetMap) |>
addPolygons(
fillColor = unname(county_colors),
@@ -426,10 +538,11 @@ map <- map_sf |>
fillOpacity = 0.75,
highlightOptions = highlightOptions(
color = "#333", bringToFront = TRUE,
- weight = 2, opacity = 1)
+ weight = 2, opacity = 1
+ )
)
-htmlwidgets::saveWidget(map, str_glue("{here::here('content','blog','2021-easy-map-norway')}/leafMap.html"))
+htmlwidgets::saveWidget(map, "leafMap.html")
```
@@ -437,4 +550,8 @@ htmlwidgets::saveWidget(map, str_glue("{here::here('content','blog','2021-easy-m
**EDIT (2022-09-04)**: Updated the blogpost to replace usage of the retiring `{fhimaps}` and `{fhidata}` packages with the newer `{splmaps}` and `{spldata}` packages from FHI. The `{fhidata}` package included a dataset on vaccination rates in Norway, but since this isn't incorporated in the new `{spldata}` package I replaced that plot with a plot about age distribution.
In addition, I also replaced all usage of the NORMENT internal `{normentR}` package with the `{scico}` package which is available on CRAN.
-**EDIT (2023-06-18)**: Updated the blogpost to reflect the deprecation of the `{splmaps}` and `{spldata}` packages. Replaced them with the replacement package `{csmaps}` available on CRAN.
\ No newline at end of file
+**EDIT (2023-06-18)**: Updated the blogpost to reflect the deprecation of the `{splmaps}` and `{spldata}` packages. Replaced them with the replacement package `{csmaps}` available on CRAN.
+
+
+
+
diff --git a/content/blog/2021-easy-map-norway/leafMap.html b/content/blog/2021-easy-map-norway/leafMap.html
index adfc58d..43b2e78 100644
--- a/content/blog/2021-easy-map-norway/leafMap.html
+++ b/content/blog/2021-easy-map-norway/leafMap.html
@@ -4917,4 +4917,4 @@