Я хочу вычислить расстояние от узла до корня dtr. Все, что у меня есть, - это вектор, содержащий идентификатор родительского узла для каждого узла rel (в этом примере id == 7 является корневым):

library(tidyverse)

tmp <- tibble(
  id = 1:12,
  rel = c(2,7,4,2,4,5,7,7,10,8,7,7)
)

В итоге ищу такой результат:

tmp $ dtr

[1] 2 1 3 2 3 4 0 1 3 2 1 1

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

Алгоритм должен работать так (Псевдокод):

  1. Если не root, увеличить dtr: if(!equals(tid,trel)): dtr = dtr+1
  2. Измените tid на trel: tid = trel
  3. Измените trel на значение rel, где id == trel
  4. Если есть !equals(tid,trel) GOTO 1., иначе END

Сначала я добавил 2 вспомогательных столбца для хранения временной информации:

tmp <- tmp %>%
  mutate(
    tid = id,
    trel = rel,
    dtr = 0
  )

Первые два шага алгоритма работают так:

tmp <- tmp %>%
  mutate(
    dtr = if_else(
      !equals(tid,trel),
      dtr + 1,
      dtr
    ),
    tid = trel
  ) 

Третий шаг, в котором я не уверен ... Я попытался добиться этого с помощью следующего кода, но он не работает:

tmp <- tmp %>% 
  mutate(trel = rel[id == .$tid])

Результат (конечно) неверный:

tmp $ rel

[1] 7 7 7 7 7 7 7 7 7 7 7 7

Но почему не это? (Это должно быть правильным решением при запуске 3. в первый раз):

[1] 2 7 2 7 2 4 7 7 10 8 7 7

Четвертый шаг выполняется проверкой, есть ли у меня более одного уникального значения в trel:

while(length(unique(tmp$trel)) > 1){
  ...
}

Таким образом, полный алгоритм должен выглядеть примерно так:

get_dtr <- function(tib){
  tmp <- tib %>%
    mutate(
      tid = id,
      trel = rel,
      dtr = 0
    )

  while(length(unique(tmp$trel)) > 1){
    tmp <- tmp %>%
      mutate(
        dtr = if_else(
          !equals(tid,trel),
          dtr + 1,
          dtr
        ),
        tid = trel
      ) 

    ### Step 3
  }
  tmp
}

Есть идеи, как решить это или более простое решение? Заранее спасибо!

2
Paavo Pohndorff 2 Янв 2018 в 18:28

2 ответа

Лучший ответ

В основном это уже реализовано в пакете tidygraph. Если вы собираетесь работать с графическими данными с помощью tidyverse, вам следует сначала посмотреть туда. ты можешь сделать

library(tidygraph)
as_tbl_graph(tmp, directed=FALSE) %>% 
  activate(nodes) %>% 
  mutate(depth=bfs_dist(root=7)) %>% 
  as_tibble()
#     name depth
#    <chr> <int>
#  1     1     2
#  2     2     1
#  3     3     3
#  4     4     2
#  5     5     3
#  6     6     4
#  7     7     0
#  8     8     1
#  9     9     3
# 10    10     2
# 11    11     1
# 12    12     1
1
MrFlick 2 Янв 2018 в 15:45

Если вы хотите написать функцию самостоятельно, вы можете использовать следующий код:

library(tidyverse)

tmp <- tibble(
  id = 1:12,
  rel = c(2,7,4,2,4,5,7,7,10,8,7,7)
)


calc_dtr <- function(id, tmp){
  # find root
  root <- tmp$id[tmp$id == tmp$rel]

  # is this the root node? 
  if(id == root){return(0)}

  # initialize counter
  dtr <- 1
  trel <- tmp$rel[tmp$id == id]

  while(trel != root){
    dtr <- dtr + 1
    trel <- tmp$rel[tmp$id == trel]
  }

  return(dtr)
}

tmp %>% 
  mutate(
    dtr = map_dbl(id, calc_dtr, tmp)
  )

Это дает следующий результат:

# A tibble: 12 x 3
      id   rel   dtr
   <int> <dbl> <dbl>
 1     1     2     2
 2     2     7     1
 3     3     4     3
 4     4     2     2
 5     5     4     3
 6     6     5     4
 7     7     7     0
 8     8     7     1
 9     9    10     3
10    10     8     2
11    11     7     1
12    12     7     1
1
Peter H. 2 Янв 2018 в 16:27