Анализ онлайн-коллекции Третьяковской галереи

Данные носят научно-развлекательный характер

Автор

Екатерина Егоренкова

Дата публикации

1.12.2024

Музейные залы завораживают своей атмосферой: они переносят посетителя в давно ушедшие эпохи, дополняют его зрительский опыт, рассказывая о прошлом и напоминая о хрупкости человеческого наследия.

Благодаря практически бессмертным онлайн-коллекциям любой человек имеет возможность беспрепятственно разглядывать и изучать тысячи шедевров в любое время.

Цель этой работы исследовать данные онлайн-коллекции Третьяковской галереи.

Часто встречающиеся авторы коллекции.
Преобладающие материалы экспонатов.
Распределение по дате создания экспоната.
Популярные слова в описаниях экспонатов.
Часто используемые прилагательные в описаниях (“красивый” не вошло даже в топ-20).
Наиболее популярные цвета.
Чаще всего упоминаемое время года.

Сбор и подготовка данных

Сбор данных

Библиотеки

library(rvest)
library(dplyr)
library(tibble)
library(tidyr)
library(stringr)
library(tidytext)
library(udpipe)
library(readr)
library(stopwords)
library(ggplot2)
library(rulexicon)
library(tidyverse)
library(googledrive)
library(kableExtra)
library(systemfonts)
library(showtext)

Данные собраны с сайта Третьяковской галереи https://my.tretyakov.ru/app/gallery.

# Получение ссылок на страницы галереи
get_gallery_links <- function(page_url) {
  Sys.sleep(1)
  html <- read_html(page_url, encoding = "UTF-8")
  
  toc <- html |> 
    html_elements(".card-title-link")
  
  gallery_lib <- tibble(
    title = toc |> 
      html_element("span") |>
      html_text(trim = TRUE),
    href = toc |> 
      html_attr("href")  
  ) |> 
    filter(!is.na(href)) |> 
    mutate(link = paste0("https://my.tretyakov.ru", href)) |>  # Добавляем базовый URL
    select(-href)
  
  return(gallery_lib)
}

# Парсинг одной картины
parse_painting <- function(painting_url) {
  tryCatch({
    Sys.sleep(1)
    html <- read_html(painting_url, encoding = "UTF-8")
    
    tibble(
      author = html_element(html, ".discription-author-name") |> html_text(trim = TRUE),
      title = html_element(html, ".discription-masterpiece-name") |> html_text(trim = TRUE),
      details = html_element(html, ".discription-masterpiece-discr") |> html_text(trim = TRUE),
      description = html_element(html, ".discription-masterpiece-biography") |> html_text(trim = TRUE),
      link = painting_url
    )
  })
}

# Парсинг всех страниц
all_paintings <- list()
total_pages <- 475  

for (page_number in 1:total_pages) {
  page_url <- paste0("https://my.tretyakov.ru/app/gallery?ignoreBanner=true&pageNum=", page_number)
  
  page_links <- get_gallery_links(page_url)
  
  page_data <- page_links |> 
    pull(link) |> 
    lapply(function(link) {
      print(paste("Parsing painting:", link)) # Смотрим, что процесс не завис
      parse_painting(link)
    }) |> 
    bind_rows()
  
  all_paintings <- append(all_paintings, list(page_data))
}

final_data <- bind_rows(all_paintings)

В результате получена таблиица, содержащая информацию о 8580 картинах.

file_url <- "https://drive.google.com/uc?id=1Wd2ejUKk9YT8FIYuyktiMTA0VAlfU0SC"
final_data_f <- read_csv(file_url, locale = locale(encoding = "Windows-1251"))

final_data_f |> 
  slice(1:10)

Редактирование данных

Редактирование колонок

В столбце “Ссылка” 389 картин имеют значение NA . Все ссылки являются уникальными идентификаторами для картин, поэтому NA заменены на уникальные значения “placeholder_”.

final_data <- final_data |> 
  mutate(
    link = ifelse(
      grepl("^https://", link),
      link,         
      paste0("placeholder_", row_number())  
    )
  )

Колонку “author” разделяем на ФИО автора и время его жизни, колонку “details” резделяем на материал и дату создания. Размер и инвентарный номер тоже отделяем, но скрываем.

# Работаем с колонкой author
final_data_split <- final_data |>
  mutate(author = trimws(author)) |>  # Спарсились лишние пробелы, убираем
  replace_na(list(author = "")) |>    # Заменяем на пустую строку NA 
  mutate(
    author_dates = sub(".*\\(([^)]+)\\).*", "\\1", author),  # Убираем скобки у дат
    author_name = sub("\\s*\\([^)]*\\)", author)  # Убираем даты из колонки имя
  ) |>
  mutate(
    author_name = na_if(trimws(author_name), ""),    # Преобразуем пустые строки обратно в NA
    author_dates = na_if(trimws(author_dates), "")
  )

final_data_split_2 <- final_data_split |>
  mutate(title = trimws(title)) |> 
  
  # Извлекаем название картины (всё до даты)
  mutate(
    painting_title = sub("^(.*?)(\\s*(?:\\d{4}[–-]?\\d{0,4}[a-zA-Zа-яА-Я]*|(?:Начало|Конец|Около|Первая половина|Вторая половина|Последняя четверть|.*\\d{4}[,;\\s]*[а-яА-Я]*\\s*\\d{4})*))$", "\\1", title)
  ) |>
  
  # Извлекаем дату
  mutate(
    painting_date = sub("^(.*?)(\\s*(?:\\d{4}[–-]?\\d{0,4}[a-zA-Zа-яА-Я]*|(?:Начало|Конец|Около|Первая половина|Вторая половина|Последняя четверть|.*\\d{4}[,;\\s]*[а-яА-Я]*\\s*\\d{4})*))$", "\\2", title)
  ) |>
  
  mutate(
    painting_date = trimws(painting_date)
  ) |>
  
  # Убираем слова, оставшиеся от дат, из painting_title
  mutate(
    painting_title = str_replace_all(painting_title, 
                                     c("Начало" = "", "Конец" = "", "Первая половина" = "",
                                       "Вторая половина" = "", "Последняя четверть" = "",
                                       "Первая четверть" = "", "Около" = "",
                                       "Первая треть" = "","Середина" = "",
                                       "века" = "","век" = ""))
  )

# Работаем с колонкой details
final_data_split_3 <- final_data_split_2 |>
  mutate(
    # Извлекаем размер без слова "Размер"
    size = str_extract(details, "Размер\\s*-\\s*([\\d,]+\\s*x\\s*[\\d,]+)") |>
      str_remove("Размер\\s*-\\s*"),
    
    # Извлекаем материал без слова "Материал", "Техника", "Инвентарный номер"
    material = str_extract(details, "Материал\\s*-\\s*([\\w\\s]+)") |>
      str_remove("Материал\\s*-\\s*") |>
      str_remove("Техника") |>
      str_remove("Инвентарный номер"),
    
    # Извлекаем технику без слова "Техника" и "Инвентарный номер"
    technique = str_extract(details, "Техника\\s*-\\s*([\\w\\s]+)") |>
      str_remove("Техника\\s*-\\s*") |>
      str_remove("Инвентарный номер")
  ) |>
  
  mutate(  # Очистка лишних пробелов в колонках
    size = trimws(size),
    material = trimws(material),
    technique = trimws(technique)
  )

# Чистим painting_date
final_data_split_4 <- final_data_split_3 |>
  mutate(
    painting_date = painting_date |>
      str_replace_all("\\s+", "") |>         # Убираем лишние пробелы
      str_replace_all("–", "-") |>           # Преобразуем длинное тире
      str_replace_all("-[хе]", "") |>        # Убираем окончания "-х" и "-е"
      str_remove_all("\\d+\\s*[xх]\\s*\\d+(,\\d+)?") |>  # Удаляем размеры
      str_remove_all("[a-zA-Zа-яА-Я]+") |>   # Убираем все буквы
      str_extract("\\d{3,4}$") |>            # Оставляем последние 3-4 цифры в строке т.к.
      as.numeric()                            # решено оставлять дату окончания написания картины
  )                                           # Преобразуем в числовой формат

Финальная таблица выглядит следующим образом.

file_url <- "https://drive.google.com/uc?id=1ugDvyzHuE_i7IHS-BZoMt-ydmNugGWd_"
final_data_selected <- read_csv(file_url, locale = locale(encoding = "Windows-1251")) |> 
  select(link, author_name, author_dates, painting_title, painting_date, material, description)

final_data_selected_1 <- final_data_selected |> 
  mutate(description = str_sub(description, 1, 100))

final_data_selected_1 |> 
  slice(1:2, 5:11)

Токенизация и лемматизация

Токенизируем колонку “Описание”, сохраняя остальные колонки. Лемматизируем, добавляем аннотацию, удаляем стоп-слова.

tokenized_data <- final_data_selected |>
  unnest_tokens(word, description, drop = FALSE)

model_path <- "russian-syntagrus-ud-2.5-191206.udpipe"

model <- udpipe_load_model(model_path)

data_annotate <- udpipe_annotate(model, final_data_selected$description)

annotated_data <- as_tibble(data_annotate)

russian_stopwords <- stopwords("ru")

custom_stopwords <- c("который", "свой", "весь", "это")

all_stopwords <- c(stopwords("ru"), custom_stopwords)

annotated_data_no_stopwords <- annotated_data_filtered |>
  filter(!lemma %in% all_stopwords)

После преобразований таблица потеряла ссылки на экспонаты, что лишает возможности перейти на сайт и увидеть экспонат. Doc_id соответствует порядковому номеру экспоната в сформированной таблице, по которому она объединяется с ссылками.

# Преобразуем doc_id
annotated_data_no_stopwords <- annotated_data_no_stopwords |>
  mutate(doc_id = as.integer(gsub("doc", "", doc_id)))   # doc на пустую строку
  
final_data <- final_data |>
  mutate(doc_id = row_number())

annotated_data_with_link <- annotated_data_no_stopwords |>
  left_join(final_data |> select(doc_id, link), 
            by = "doc_id")  # Сопоставляем doc_id из final_data

Важно: Следующий код скачивает файл локально.

file_id <- "1PS0IohMMIOgpcYzVLEJ5hCuPeHw_p0LR"

# Загружаем файл с Google Drive в локальный файл
drive_download(as_id(file_id), path = "annotated_data_with_link.csv", overwrite = TRUE)

annotated_data_with_link <- read_delim("annotated_data_with_link.csv", delim = ",", locale = locale(encoding = "Windows-1251"))

head(annotated_data_with_link)

Графики

Часто встречающиеся авторы коллекции

Подгружаем таблицу.

Строим график.

author_popularity <- final_data_selected_2 |>
  mutate(author_name = replace_na(author_name, "Неизвестный автор")) |> 
  group_by(author_name) |>
  summarise(count = n()) |>
  arrange(desc(count))       

top_authors <- author_popularity |>
  slice(1:14)

ggplot(top_authors, aes(x = reorder(author_name, count), y = count)) +
  geom_bar(stat = "identity", fill = "#78C2AD") +
  coord_flip() +
  labs(
    title = "Часто встречающиеся авторы коллекции",
    x = "",
    y = ""
  ) +
  theme_minimal()+
  theme(
    text = element_text(family = "source_sans_pro"),
    legend.position = "none",
    plot.margin = unit(c(0.2, 0.2, 0.2, 0.2), "cm")
  )

Преобладают экспонаты неизвестных авторов, что вполне объяснимо для любой коллекции. Васнецовы, Репин, Врубель, Серов были ожидаемы среди часто встречаемых авторов в коллекции. Открытием стала автор, занимающая второе место, Голубкина Анна.

Преобладающие материалы экспонатов

material_popularity <- final_data_selected |>
  filter(!is.na(material)) |>  
  group_by(material) |>
  summarise(count = n()) |>  
  arrange(desc(count))       

top_material <- material_popularity |>
  slice(1:15)

ggplot(top_material, aes(x = reorder(material, count), y = count)) +
  geom_bar(stat = "identity", fill = "#78C2AD") +
  coord_flip() +  
  labs(
    title = "Преобладающие материалы экспонатов",
    x = NULL, 
    y = NULL 
  ) +
  theme_minimal() +
  theme(
    text = element_text(family = "Arial"),
    legend.position = "none",  
    plot.margin = unit(c(0.2, 0.2, 0.2, 0.2), "cm")
  )

Этот график не отражает экспонаты, у которых материалы не указаны. Ожидаемо материалы “бумага”, “холст” заняли первые места.

Особенность этого графика в том, что, например, “гипс” и “гипс тонированный”, “холст” и “холст на картоне” это разные объекты. Но даже при суммировании таких объектов, экспонатов с материалами “бумага”, “холст” больше, чем всех остальных.

Распределение по дате создания экспоната

Распределение осуществлено по дате создания экспоната и начинается с 1600 года. В коллекции есть и небольшое количество более ранних экспонатов, которые на этом графике не отражены (в масштабе общего графика более ранние произведения близки к отметке 0).

# Преобразуем даты в десятилетия
year_analysis <- final_data_selected |>
  filter(!is.na(painting_date)) |>
  mutate(decade = (as.numeric(painting_date) %/% 10) * 10) |>
  count(decade, sort = TRUE)

ggplot(year_analysis, aes(x = decade, y = n)) +
  geom_line(color = "#78C2AD") +
  geom_point(color = "#F4A460", size = 2) +
  scale_x_continuous(limits = c(1600, NA)) + # Начало оси x с 1300
  labs(
    title = "Распределение дат создания картин",
    x = "",
    y = ""
  ) +
  theme_minimal() +
  theme(
    text = element_text(family = "Arial"),
    legend.position = "none",
    plot.margin = unit(c(0.2, 0.2, 0.2, 0.2), "cm")
  )

Пик приходится на период 1900-1950 года. Также большое количество отмечено 1600-1650 годами, но когда речь идет о таких датах, важно помнить, что дата не всегда установлена точно.
Важно отметить, присутствие экспонатов, созданных после 2000 года и их количество. Публикация работ современников в открытом доступе не может не радовать. Можно предположить, что у галереи хорошо налажены отношения с современными мастерами.

Часто используемые прилагательные в описаниях

# Общее количество всех прилагательных в тексте
total_adjectives <- annotated_data_with_link |>
  filter(upos == "ADJ") |>  # Фильтруем только прилагательные
  count(lemma, sort = TRUE) |>
  summarise(total = sum(n)) |>
  pull(total)

# Подсчет относительной частоты
adjective_relative_frequency <- annotated_data_with_link |>
  filter(upos == "ADJ") |>  # Фильтруем только прилагательные
  count(lemma, sort = TRUE) |>
  mutate(relative_frequency = n / total_adjectives)

top_adjective_lemmas <- adjective_relative_frequency |>
  slice_max(relative_frequency, n = 20)

ggplot(top_adjective_lemmas, aes(x = reorder(lemma, relative_frequency), y = relative_frequency)) +
  geom_bar(stat = "identity", fill = "#78C2AD") +
  coord_flip() +
  labs(
    title = "Часто используемые прилагательные в описаниях",
    x = "",
    y = ""
  ) +
  theme_minimal() +
  theme(
    text = element_text(family = "Arial"),
    legend.position = "none", 
    plot.margin = unit(c(0.2, 0.2, 0.2, 0.2), "cm")
  )

Прилагательные дают более интересную картину. Самое распространенное прилагательное “русский”. Часто картины описывают словами “большой”, “живописный”, “яркий”, “белый”, “древний”. Интересно то, что на график не попало ни одного негативно окрашенного прилагательного.

Наиболее популярные цвета

Попробуем определить основные цвета оналйн-коллекции на основе описаний. Для этого составим список цветов и оттеноков, который будем искать в описаниях.

color_palette <- c(
  "красный" = "red", "синий" = "blue", "зеленый" = "green", "желтый" = "yellow", 
  "оранжевый" = "orange", "фиолетовый" = "purple", "белый" = "white", 
  "черный" = "black", "серый" = "gray", "розовый" = "pink", 
  "коричневый" = "brown", "голубой" = "skyblue", "бежевый" = "beige", 
  "бордовый" = "#800020", "пурпурный" = "#800080", "золотистый" = "gold", 
  "серебристый" = "#C0C0C0", "изумрудный" = "#50C878", "алый" = "#FF2400", 
  "песочный" = "#F4A460", "охристый" = "#CC7722", "лазурный" = "#007FFF", 
  "бирюзовый" = "#30D5C8", "салатовый" = "#99FF99", "лиловый" = "#C8A2C8", 
  "янтарный" = "#FFBF00", "малахитовый" = "#0BDA51", "каштановый" = "#954535", 
  "светло-серый" = "#D3D3D3", "темно-серый" = "#A9A9A9", 
  "светло-зеленый" = "#90EE90", "темно-зеленый" = "#006400", 
  "оливковый" = "#808000", "фиалковый" = "#8A2BE2", "пепельный" = "#B2BEB5", 
  "угольный" = "#36454F", "хаки" = "#F0E68C", "пастельный" = "#FFB6C1", 
  "карамельный" = "#FFD59A", "ванильный" = "#F3E5AB"
)

color_absolute_frequency <- annotated_data_with_link |>
  filter(lemma %in% names(color_palette)) |>
  count(lemma, sort = TRUE)

ggplot(color_absolute_frequency, aes(x = reorder(lemma, n), y = n, fill = lemma)) +
  geom_bar(stat = "identity", aes(color = ifelse(lemma == "белый", "black", NA))) +  # Обводка только для белого
  scale_fill_manual(values = color_palette) +  
  scale_color_identity() +  # Используем цвет для обводки
  coord_flip() +
  labs(
    title = "Наиболее популярные цвета",
    x = "",
    y = ""
  ) +
  theme_minimal()  +
  theme(
    text = element_text(family = "Arial"),
    legend.position = "none", 
    plot.margin = unit(c(0.2, 0.2, 0.2, 0.2), "cm")
  )

На первом месте белый цвет, который также попал и в список самых популярных прилагательных в предыдущем разделе. Нужно помнить, что список цветов составлен вручную и может быть неполным.

Чаще всего упоминаемое время года

seasons_lemmas <- c("весна", "лето", "осень", "зима", "весенний", "летний", "осенний", "зимний")

season_data <- annotated_data_with_link |>
  filter(lemma %in% seasons_lemmas) |>
  count(lemma, sort = TRUE)

season_groups <- season_data |>
  mutate(season = case_when(
    lemma %in% c("весна", "весенний") ~ "Весна",
    lemma %in% c("лето", "летний") ~ "Лето",
    lemma %in% c("осень", "осенний") ~ "Осень",
    lemma %in% c("зима", "зимний") ~ "Зима"
  )) |>
  group_by(season) |>
  summarise(total = sum(n)) |>
  arrange(desc(total))

ggplot(season_groups, aes(x = reorder(season, total), y = total, fill = season)) +
  geom_bar(stat = "identity") +
  scale_fill_manual(values = c("Весна" = "#FFB6C1", "Лето" = "#78C2AD", "Осень" = "#F4A460", "Зима" = "skyblue")) +
  coord_flip() +
  labs(
    title = "Упоминания времен года в описаниях",
    x = "",
    y = ""
  ) +
  theme_minimal()  +
  theme(
    text = element_text(family = "Arial"),
    legend.position = "none",
    plot.margin = unit(c(0.2, 0.2, 0.2, 0.2), "cm")
  )

Лето встречается в описаниях почти в 2 раза чаще, чем любое другое время года.

Это мини-исследование лишь поверхностно прошлось по собранным данным, но натолкнуло на более интересные вопросы. Например, почему именно белый цвет самый популярный (Ответ на этот вопрос могло бы дать изучение совместной встречаемости этого слова)? Кого чаще изображали на картинах и статуях в разные периоды? Как меняется описание экспонатов в зависимости от даты их создания? Насколько отличаются тексты описаний в разных музеях?

Эти и многие другие вопросы нам позволяют исследовать онлайн-коллекции музеев по всему миру.

В новом информационном пространстве музей будет служить узлом в сети, соединяющей предметы, информацию, людей и места Navarrete и Mackenzie Owen (2016).

использованная литература

Navarrete, Trilce, и John Mackenzie Owen. 2016. «The museum as information space: Metadata and documentation». Cultural Heritage in a Changing World, 111–23.