BB8 Starwars

Кто встречается в тех же фильмах, что и BB8

Создаем эго-граф для BB8

library(dplyr)
library(tidyr)
library(tidygraph)
library(ggraph)
library(ggplot2)
library(visNetwork)
library(ggimage)


data("starwars")

starwars_expanded <- starwars |>
  select(name, films, homeworld) |>
  unnest(films)

edges <- starwars_expanded |>
  inner_join(starwars_expanded, by = "films") |>
  filter(name.x != name.y) |>  # Петли
  select(from = name.x, to = name.y, film = films)

edges <- edges |>
  distinct(from, to, .keep_all = TRUE)

# BB8
bb8_edges <- edges |>
  filter(from == "BB8" | to == "BB8")

bb8_neighbors <- unique(c(bb8_edges$from, bb8_edges$to))

bb8_ego_edges <- edges |>
  filter(from %in% bb8_neighbors & to %in% bb8_neighbors)

bb8_ego_nodes <- starwars |>
  filter(name %in% bb8_neighbors) |>
  select(name, sex, homeworld)

bb8_ego_graph <- as_tbl_graph(bb8_ego_edges, directed = FALSE) |>
  activate(nodes) |>
  left_join(bb8_ego_nodes, by = c("name" = "name"))

Для наглядности будем использовать фотографии персонажей в качестве узлов

bb8_ego_graph <- bb8_ego_graph |>
  activate(nodes)  |> 
  mutate(
    image = paste0("./", name, ".jpg")  
  )

# Визуализация графа
set.seed(21092024)
ggraph(bb8_ego_graph, layout = "dh", maxiter = 100) +
  geom_edge_arc(color = "grey50", strength = 0.2) +
  geom_image(aes(x = x, y = y, image = image), size = 0.1) +
  geom_node_label(
    aes(label = name), 
    size = 3, 
    color = "black", 
    fill = "white", 
    alpha = 0.8, 
    repel = TRUE,
    nudge_y = -0.15,  # Смещение подписей вниз 
    label.padding = unit(0.15, "lines"),
    label.size = 0  
  )
  theme_graph(base_family = "sans") +  
  theme(legend.position = "bottom") 

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

nodes <- bb8_ego_nodes |>
  mutate(
    id = name, 
    label = name, 
    sex = ifelse(sex == "female", "f", "m"),
    shape = "icon", 
    icon.face = "FontAwesome",
    icon.code = ifelse(sex == "f", "f182", "f183"),
    icon.size = 50, 
    icon.color = ifelse(sex == "f", "pink", "lightblue"),
    title = paste("Name:", name, "<br>Homeworld:", homeworld),  # Всплывающие подсказки
  ) 

edges <- bb8_ego_edges |>
  mutate(from = from, 
         to = to)

visNetwork(nodes, edges, width = "100%", height = "600px") |>
  visOptions(
    highlightNearest = list(enabled = TRUE, degree = 1, hover = TRUE, algorithm = "all"),  
    nodesIdSelection = TRUE
  ) |>
  visPhysics(maxVelocity = 20, stabilization = FALSE) |>
  visInteraction(
    dragNodes = TRUE,
    hoverConnectedEdges = TRUE, 
    hover = TRUE
  ) |>
  addFontAwesome()

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