Web scrapping for potato pedigree

get_pedigree_graph <- function(image_id, depth = 5){
  page_url <- paste0(
    "https://www.plantbreeding.wur.nl/PotatoPedigree/pedigree_imagemap.php?id=", 
    image_id,
    "&showjaar=0&depth=",
    depth)
  raw_html <- read_html(page_url)
  
  ## Get the HTML code for the interactive plot above the static image
  graph_html <- raw_html %>% 
    html_nodes("map") %>% 
    html_children()
  
  graph_df <- reduce(xml_attrs(graph_html), bind_rows) %>% 
    select(title, coords) %>% 
    separate(coords, c("x1", "y1", "x2", "y2"), ",", convert = TRUE) %>% 
    ## Compute center of the nodes (each representing a variety)
    ## The x position determines the generation or level of the variety
    mutate(x = (x1 + x2) / 2,
           y = (y1 + y2) / 2,
           generation = factor(x),
           generation = as.numeric(generation) - 1) %>% 
    select(name = title, generation, x, y) %>% 
    filter(name != "unknown")
  
  return(graph_df)
}

get_pedigree_edges <- function(graph_df){
  
  ## How many generations are there in the graph
  n_gens <- n_distinct(graph_df$generation)
  
  ## What is the distance on the y-axis between a parent and its child
  par_dist <- sapply(0:(n_gens - 2), function(i){
    expand_grid(genc = filter(graph_df, generation == i)$y, 
                geno = filter(graph_df, generation == (i + 1))$y) %>% 
      mutate(diff = abs(genc - geno)) %>% 
      pull(diff) %>% 
      min()
  })
  
  edges_df <- lapply(
    which(graph_df$generation < max(graph_df$generation)), 
    function(i){
      i_name <- graph_df$name[i]
      i_gen <- graph_df$generation[i]
      i_y <- graph_df$y[i]
      
      ## Parents are the nodes one generation up and with the correct distance
      ## on the y axis to the current node investigated
      parents <- graph_df %>% 
        filter(generation == i_gen + 1) %>% 
        mutate(distance = abs(y - i_y)) %>% 
        filter(distance == par_dist[i_gen + 1]) %>% 
        pull(name)
      
      ## Making sure that we never see more than 2 parents
      if(length(parents) > 2) error("more than 2 parents for row ", i)
      
      if(length(parents)){
        tibble(to = i_name,
               ## This way the ordering of two parents is the same 
               ## for all graphs
               from = sort(parents),
               ## Make sure to keep both edges if a variety is a 
               ## self of the parent
               parentID = 1:length(parents))
      } else {
        tibble(to = NULL, from = NULL, parentID = NULL)
      }
      
    }
  ) %>% 
    reduce(bind_rows) %>% 
    distinct()
}

get_pedigree_nodes <- function(edges_df, max_level = 10){
  
  ## Make the nodes df and tidy up nodes label
  nodes_df <- tibble(id = unique(c(edges_df$to, edges_df$from)),
                     label = id) %>% 
    mutate(label = case_when(
      str_detect(label, "^[^\\n]{11}") ~ str_replace(label, " x ", "\nx "),
      TRUE ~ label
    ),
    label = case_when(
      str_detect(label, "^[^\\n]{11}") ~ str_replace(label, " ", "\n"),
      TRUE ~ label)
    )
  
  nodes <- nodes_df$id
  
  ## Get the end nodes, as the ones with no edges coming out of them
  gen0_nodes <- setdiff(nodes, unique(edges_df$from))
  
  nodes_level <- rep(NA_integer_, length(nodes))
  nodes_y <- rep(NA_integer_, length(nodes))
  names(nodes_level) <- names(nodes_y) <- nodes
  
  nodes_level[gen0_nodes] <- 0
  nodes_y[gen0_nodes] <- seq(1, 
                             length(gen0_nodes)*2^max_level, 
                             by = 2^max_level)
  
  current_nodes <- gen0_nodes
  current_level <- 0
  
  while(length(current_nodes)){
    current_level <- current_level + 1
    
    parents_df <- edges_df %>% 
      filter(to %in% current_nodes)
    
    new_nodes <- parents_df$from
    
    nodes_level[new_nodes] <- current_level
    nodes_y[new_nodes] <- nodes_y[parents_df$to] + 
      (parents_df$parentID - 1) * 2^(max_level - current_level)
    
    current_nodes <- new_nodes
  }
  
  nodes_df %>% 
    mutate(level = nodes_level[id],
           y = nodes_y[id])
  
}

plot_pedigree <- function(image_ids, 
                          depths, 
                          nodes_highlight = NULL, 
                          edges_to_add = NULL){
  
  ## Allow user to choose different depths for each pedigree
  ## If only provides one depth value, will apply it to all queried pedigrees
  if((length(depths) == 1) & (length(image_ids) > 1)){
    depths <- rep(depths, length(image_ids))
  } 
  
  ## Extract pedigree information from webpage
  graph_list <- lapply(1:length(image_ids), function(i){
    get_pedigree_graph(image_ids[i], depths[i])
  })
  
  ## Extract parental relationships from pedigree info
  edges_df <- lapply(graph_list, get_pedigree_edges) %>% 
    reduce(bind_rows) %>% 
    distinct() 
  
  ## Add the custom edges to edges dataframe
  if(!is.null(edges_to_add)) {
    edges_df <- edges_df %>% 
      bind_rows(edges_to_add) %>% 
      distinct()
  }
  
  ## Construct nodes from parental relationships
  nodes_df <- get_pedigree_nodes(edges_df)
  
  ## Add highlight for nodes of interest
  if(!is.null(nodes_highlight)){
    pattern <- paste0("(", paste0("(", nodes_highlight, ")", 
                                  collapse = "|"),
                      ")")
    nodes_df <- nodes_df %>% 
      mutate(group = str_detect(id, regex(pattern, ignore_case = TRUE)),
             group = factor(group))
  } else {
    nodes_df <- nodes_df %>% 
      mutate(group = factor("FALSE", levels = c("FALSE", "TRUE")))
  }
  
  visNetwork(nodes_df, edges_df, width = "100%", height = 1500) %>% 
    visEdges(arrows = "to") %>% 
    visHierarchicalLayout(direction = "LR") %>% 
    visGroups(groupname = "FALSE", 
              color = list(border = "#1560D1", background = "#347DEB")) %>%
    visGroups(groupname = "TRUE",
              color = list(border = "#B35900", background = "#FF9933"))
}

plot_pedigree(c(15504,   ## Red Rascal
                14802),  ## Pacific
              depths = c(4, 3),
              nodes_highlight = c("Red Rascal", "Pacific", "My own cross!"),
              ## Completely made-up edge
              edges_to_add = tibble(from = c("V394", "PACIFIC"),
                                    to = rep("My own cross!", 2)))

library(rvest)
library(xml2)
library(tidyverse)

page_url <- "https://www.plantbreeding.wur.nl/PotatoPedigree/pedigree_imagemap.php?id=15504"
raw_html <- read_html(page_url)

graph_html <- raw_html %>% 
  html_nodes("map") %>% 
  html_children()

graph_df <- reduce(xml_attrs(graph_html), bind_rows)

head(graph_df) %>% 
  knitr::kable()

graph_df <- reduce(xml_attrs(graph_html), bind_rows) %>%
  select(title, coords) %>% 
  separate(coords, c("x1", "y1", "x2", "y2"), ",", convert = TRUE) %>%
  mutate(x = (x1 + x2) / 2,
         y = (y1 + y2) / 2)

graph_df <- reduce(xml_attrs(graph_html), bind_rows) %>%
  select(title, coords) %>% 
  separate(coords, c("x1", "y1", "x2", "y2"), ",", convert = TRUE) %>%
  mutate(x = (x1 + x2) / 2,
         y = (y1 + y2) / 2,
         generation = factor(x),
         generation = as.numeric(generation) - 1)

graph_df <- reduce(xml_attrs(graph_html), bind_rows) %>%
  select(title, coords) %>% 
  separate(coords, c("x1", "y1", "x2", "y2"), ",", convert = TRUE) %>%
  mutate(x = (x1 + x2) / 2,
         y = (y1 + y2) / 2,
         generation = factor(x),
         generation = as.numeric(generation) - 1) %>% 
  select(name = title, generation, x, y) %>% 
  filter(name != "unknown")

get_pedigree_graph <- function(image_id, depth = 5){
  page_url <- paste0(
    "https://www.plantbreeding.wur.nl/PotatoPedigree/pedigree_imagemap.php?id=", 
    image_id,
    "&showjaar=0&depth=",
    depth)
  raw_html <- read_html(page_url)
  
  ## Get the HTML code for the interactive plot above the static image
  graph_html <- raw_html %>% 
    html_nodes("map") %>% 
    html_children()
  
  graph_df <- reduce(xml_attrs(graph_html), bind_rows) %>% 
    select(title, coords) %>% 
    separate(coords, c("x1", "y1", "x2", "y2"), ",", convert = TRUE) %>% 
    ## Compute center of the nodes (each representing a variety)
    ## The x position determines the generation or level of the variety
    mutate(x = (x1 + x2) / 2,
           y = (y1 + y2) / 2,
           generation = factor(x),
           generation = as.numeric(generation) - 1) %>% 
    select(name = title, generation, x, y) %>% 
    filter(name != "unknown")
  
  return(graph_df)
}

get_pedigree_graph(15504, 6) %>% 
  tail() %>% 
  knitr::kable()

## How many generations are there in the graph
n_gens <- n_distinct(graph_df$generation)

## What is the distance on the y-axis between a parent and its child
par_dist <- sapply(0:(n_gens - 2), function(i){
  expand_grid(genc = filter(graph_df, generation == i)$y, 
              geno = filter(graph_df, generation == (i + 1))$y) %>% 
    mutate(diff = abs(genc - geno)) %>% 
    pull(diff) %>% 
    min()
})

edges_df <- lapply(which(graph_df$generation < max(graph_df$generation)), function(i){
  i_name <- graph_df$name[i]
  i_gen <- graph_df$generation[i]
  i_y <- graph_df$y[i]
  
  ## Parents are the nodes one generation up and with the correct distance
  ## on the y axis to the current node investigated
  parents <- graph_df %>% 
    filter(generation == i_gen + 1) %>% 
    mutate(distance = abs(y - i_y)) %>% 
    filter(distance == par_dist[i_gen + 1]) %>% 
    pull(name)
  
  ## Making sure that we never see more than 2 parents
  if(length(parents) > 2) error("more than 2 parents for row ", i)
  
  if(length(parents)){
    tibble(to = i_name,
           ## This way the ordering of two parents is the same for all graphs
           from = sort(parents),
           ## Make sure to keep both edges if a variety is a self of the parent
           parentID = 1:length(parents))
  } else {
    tibble(to = NULL, from = NULL, parentID = NULL)
  }
  
}) %>% 
  reduce(bind_rows) %>% 
  distinct()

get_pedigree_edges <- function(graph_df){
  
  ## How many generations are there in the graph
  n_gens <- n_distinct(graph_df$generation)
  
  ## What is the distance on the y-axis between a parent and its child
  par_dist <- sapply(0:(n_gens - 2), function(i){
    expand_grid(genc = filter(graph_df, generation == i)$y, 
                geno = filter(graph_df, generation == (i + 1))$y) %>% 
      mutate(diff = abs(genc - geno)) %>% 
      pull(diff) %>% 
      min()
  })
  
  edges_df <- lapply(
    which(graph_df$generation < max(graph_df$generation)), 
    function(i){
      i_name <- graph_df$name[i]
      i_gen <- graph_df$generation[i]
      i_y <- graph_df$y[i]
      
      ## Parents are the nodes one generation up and with the correct distance
      ## on the y axis to the current node investigated
      parents <- graph_df %>% 
        filter(generation == i_gen + 1) %>% 
        mutate(distance = abs(y - i_y)) %>% 
        filter(distance == par_dist[i_gen + 1]) %>% 
        pull(name)
      
      ## Making sure that we never see more than 2 parents
      if(length(parents) > 2) error("more than 2 parents for row ", i)
      
      if(length(parents)){
        tibble(to = i_name,
               ## This way the ordering of two parents is the same 
               ## for all graphs
               from = sort(parents),
               ## Make sure to keep both edges if a variety is a 
               ## self of the parent
               parentID = 1:length(parents))
      } else {
        tibble(to = NULL, from = NULL, parentID = NULL)
      }
      
    }
  ) %>% 
    reduce(bind_rows) %>% 
    distinct()
}

## Make the nodes df and tidy up nodes label
nodes_df <- tibble(id = unique(c(edges_df$to, edges_df$from)),
                   label = id) %>% 
  mutate(label = case_when(
    str_detect(label, "^[^\\n]{11}") ~ str_replace(label, " x ", "\nx "),
    TRUE ~ label
  ),
  label = case_when(
    str_detect(label, "^[^\\n]{11}") ~ str_replace(label, " ", "\n"),
    TRUE ~ label
  ))

max_level <- 10

nodes <- nodes_df$id

## Step 1: initialise level and position of nodes to NA
nodes_level <- rep(NA_integer_, length(nodes))
nodes_y <- rep(NA_integer_, length(nodes))
names(nodes_level) <- names(nodes_y) <- nodes

## Step 2: Get the end nodes, as the ones with no edges coming out of them
focus_nodes <- setdiff(nodes, unique(edges_df$from))
nodes_level[focus_nodes] <- 0

## Step 3: compute the position of the end nodes
nodes_y[focus_nodes] <- seq(1, length(focus_nodes)*2^max_level, by = 2^max_level)

## Step 4: loop over my focus nodes
## The loop stops when we run out of focus nodes
current_level <- 0

while(length(focus_nodes)){
  
  ## Step 5: increase the current level by 1
  current_level <- current_level + 1
  
  ## Step 6: find the parents of the current focus nodes...
  parents_df <- edges_df %>% 
    filter(to %in% focus_nodes)
  
  new_nodes <- parents_df$from
  
  ## ... and set their level to the current level
  nodes_level[new_nodes] <- current_level
  
  ## Step 7: I compute the position of the new nodes
  ## based on the position of their children
  nodes_y[new_nodes] <- nodes_y[parents_df$to] + (parents_df$parentID - 1) * 2^(max_level - current_level)
  
  ## I set the parent nodes as my new focus nodes
  focus_nodes <- new_nodes
}

nodes_df %>% 
  mutate(level = nodes_level[id],
         y = nodes_y[id])

get_pedigree_nodes <- function(edges_df, max_level = 10){
  
  ## Make the nodes df and tidy up nodes label
  nodes_df <- tibble(id = unique(c(edges_df$to, edges_df$from)),
                     label = id) %>% 
    mutate(label = case_when(
      str_detect(label, "^[^\\n]{11}") ~ str_replace(label, " x ", "\nx "),
      TRUE ~ label
    ),
    label = case_when(
      str_detect(label, "^[^\\n]{11}") ~ str_replace(label, " ", "\n"),
      TRUE ~ label)
    )
  
  nodes <- nodes_df$id
  
  ## Get the end nodes, as the ones with no edges coming out of them
  gen0_nodes <- setdiff(nodes, unique(edges_df$from))
  
  nodes_level <- rep(NA_integer_, length(nodes))
  nodes_y <- rep(NA_integer_, length(nodes))
  names(nodes_level) <- names(nodes_y) <- nodes
  
  nodes_level[gen0_nodes] <- 0
  nodes_y[gen0_nodes] <- seq(1, 
                             length(gen0_nodes)*2^max_level, 
                             by = 2^max_level)
  
  current_nodes <- gen0_nodes
  current_level <- 0
  
  while(length(current_nodes)){
    current_level <- current_level + 1
    
    parents_df <- edges_df %>% 
      filter(to %in% current_nodes)
    
    new_nodes <- parents_df$from
    
    nodes_level[new_nodes] <- current_level
    nodes_y[new_nodes] <- nodes_y[parents_df$to] + 
      (parents_df$parentID - 1) * 2^(max_level - current_level)
    
    current_nodes <- new_nodes
  }
  
  nodes_df %>% 
    mutate(level = nodes_level[id],
           y = nodes_y[id])
  
}

library(visNetwork)

edges_df <- get_pedigree_edges(graph_df)
nodes_df <- get_pedigree_nodes(edges_df)

visNetwork(nodes_df, edges_df, width = "100%", height = 1500) %>% 
    visEdges(arrows = "to") %>% 
    visHierarchicalLayout(direction = "LR")

nodes_highlight <- c("Red Rascal", "Urgenta")

pattern <- paste0("(", paste0("(", nodes_highlight, ")", collapse = "|"), ")")

nodes_df <- nodes_df %>% 
  mutate(group = str_detect(id, regex(pattern, ignore_case = TRUE)),
         group = factor(group))

  visNetwork(nodes_df, edges_df, width = "100%", height = 1500) %>% 
    visEdges(arrows = "to") %>% 
    visHierarchicalLayout(direction = "LR") %>% 
    visGroups(groupname = "FALSE", color = list(border = "#1560D1", background = "#347DEB")) %>%
    visGroups(groupname = "TRUE", color = list(border = "#B35900", background = "#FF9933"))

plot_pedigree <- function(image_id, depth = 5, nodes_highlight = NULL){
  
  ## Extract pedigree information from webpage source code
  graph_df <- get_pedigree_graph(image_id, depth)
  
  ## Extract parental relationships from pedigree info
  edges_df <- get_pedigree_edges(graph_df)
  
  ## Construct nodes from parental relationships
  nodes_df <- get_pedigree_nodes(edges_df)
  
  ## Add highlight for nodes of interest
  if(!is.null(nodes_highlight)){
    pattern <- paste0("(", paste0("(", nodes_highlight, ")", collapse = "|"), ")")
    
    nodes_df <- nodes_df %>% 
      mutate(group = str_detect(id, regex(pattern, ignore_case = TRUE)),
             group = factor(group))
  } else {
    nodes_df <- nodes_df %>% 
      mutate(group = factor("FALSE", levels = c("FALSE", "TRUE")))
  }
  
  ## Plot network
  visNetwork(nodes_df, edges_df, width = "100%", height = 1500) %>% 
    visEdges(arrows = "to") %>% 
    visHierarchicalLayout(direction = "LR") %>% 
    visGroups(groupname = "FALSE", color = list(border = "#1560D1", background = "#347DEB")) %>%
    visGroups(groupname = "TRUE", color = list(border = "#B35900", background = "#FF9933"))
}

plot_pedigree <- function(image_ids, 
                          depths, 
                          nodes_highlight = NULL, 
                          edges_to_add = NULL){
  
  ## Allow user to choose different depths for each pedigree
  ## If only provides one depth value, will apply it to all queried pedigrees
  if((length(depths) == 1) & (length(image_ids) > 1)){
    depths <- rep(depths, length(image_ids))
  } 
  
  ## Extract pedigree information from webpage
  graph_list <- lapply(1:length(image_ids), function(i){
    get_pedigree_graph(image_ids[i], depths[i])
  })
  
  ## Extract parental relationships from pedigree info
  edges_df <- lapply(graph_list, get_pedigree_edges) %>% 
    reduce(bind_rows) %>% 
    distinct() 
  
  ## Add the custom edges to edges dataframe
  if(!is.null(edges_to_add)) {
    edges_df <- edges_df %>% 
      bind_rows(edges_to_add) %>% 
      distinct()
  }
  
  ## Construct nodes from parental relationships
  nodes_df <- get_pedigree_nodes(edges_df)
  
  ## Add highlight for nodes of interest
  if(!is.null(nodes_highlight)){
    pattern <- paste0("(", paste0("(", nodes_highlight, ")", 
                                  collapse = "|"),
                      ")")
    nodes_df <- nodes_df %>% 
      mutate(group = str_detect(id, regex(pattern, ignore_case = TRUE)),
             group = factor(group))
  } else {
    nodes_df <- nodes_df %>% 
      mutate(group = factor("FALSE", levels = c("FALSE", "TRUE")))
  }
  
  visNetwork(nodes_df, edges_df, width = "100%", height = 1500) %>% 
    visEdges(arrows = "to") %>% 
    visHierarchicalLayout(direction = "LR") %>% 
    visGroups(groupname = "FALSE", 
              color = list(border = "#1560D1", background = "#347DEB")) %>%
    visGroups(groupname = "TRUE",
              color = list(border = "#B35900", background = "#FF9933"))
}

plot_pedigree(c(15504,   ## Red Rascal
                14802),  ## Pacific
              depths = c(4, 3),
              nodes_highlight = c("Red Rascal", "Pacific", "My own cross!"),
              ## Completely made-up edge
              edges_to_add = tibble(from = c("V394", "PACIFIC"),
                                    to = rep("My own cross!", 2)))