Использование purrr для извлечения значений из вложенного фрейма данных на основе условия

ProgramBox

Использование purrr для извлечения значений из вложенного фрейма данных на основе условия

Post author:admin
Запись опубликована:26 февраля, 2023
Post category:Вопросы по программированию

#r #purrr

Вопрос:

Я работаю с набором результатов тестирования пациента, некоторые из которых являются положительными и отрицательными. Я уменьшаю использование до уровня отдельного пациента dplyr::nest() , а затем извлекаю значения только для первого положительного теста, используя purrr::map() и функцию, которую я написал. Мой набор данных невелик — ~ 40 тыс. уникальных пациентов, ~ 110 тыс. результатов тестов — но я отказался от запуска своего скрипта через 40 минут. Я уверен, что есть лучший способ извлечения этих значений, но я изо всех сил пытаюсь его решить. Приведенный ниже фрагмент кода иллюстрирует метод, который я использую (хотя, очевидно, это выполняется в кратчайшие сроки).

 library(tidyverse)

example_data <- tribble(
  
  ~patient, ~is_first_positive, ~score_1, ~score_2,
  "A", F, 10, 45,
  "A", T, 16, 76,
  "A", F, 24, 86,
  "B", T, 17, 5,
  "B", F, 24, 22,
  "B", F, 55, 97,
  "C", F, 67, 48,
  "C", F, 23, 38,
  "C", F, 45, 16
  
)

example_data <- example_data %>% 
  group_by(patient) %>% 
  nest()

# function to extract values based on value of another column
get_field <- function(df, logical_field, rtn_field) {
  
  df <- df %>% filter_(logical_field)
  
  if(nrow(df)==0) {
    return(NA_integer_)
  } else {
    df %>% pull({{rtn_field}}) %>% as.integer() %>% return()
  }

}

# Use purrr to run function against each nested df
example_data <- example_data %>% 
  mutate(first_positive_score1 = map_int(data, ~get_field(., "is_first_positive", score_1)),
         first_positive_score2 = map_int(data, ~get_field(., "is_first_positive", score_2)))

Ответ №1:

Вот альтернатива, которая должна быть довольно быстрой:

Фильтр для сохранения только первого положительного результата
Объедините вложенные данные, если вам это нужно

 library(tidyverse)

example_data <- tribble(
  ~patient, ~is_first_positive, ~score_1, ~score_2,
  "A", F, 10, 45,
  "A", T, 16, 76,
  "A", F, 24, 86,
  "B", T, 17, 5,
  "B", F, 24, 22,
  "B", F, 55, 97,
  "C", F, 67, 48,
  "C", F, 23, 38,
  "C", F, 45, 16
)

nested_data <- example_data %>% 
  group_by(patient) %>% 
  nest()

example_data %>% 
  filter(is_first_positive) %>%
  group_by(patient) %>%
  top_n(1) %>%
  full_join(nested_data)

#> Selecting by score_2
#> Joining, by = "patient"
#> # A tibble: 3 x 5
#> # Groups:   patient [3]
#>   patient is_first_positive score_1 score_2 data            
#>   <chr>   <lgl>               <dbl>   <dbl> <list>          
#> 1 A       TRUE                   16      76 <tibble [3 × 3]>
#> 2 B       TRUE                   17       5 <tibble [3 × 3]>
#> 3 C       NA                     NA      NA <tibble [3 × 3]>

Учитывая ваш комментарий, я переписал вашу get_field функцию, используя базовые функции R, и смог добиться улучшения скорости в 10 раз:

 get_field <- function(df, logical_field, rtn_field) {
  df <- df %>% filter_(logical_field)
  if(nrow(df)==0) {
    return(NA_integer_)
  } else {
    df %>% pull({{rtn_field}}) %>% as.integer() %>% return()
  }
}

get_field2 <- function(x, logical_field, rtn_field) {
  x <- x[x[[logical_field]], ]
  ifelse(nrow(x)==0, NA_integer_, x[[rtn_field]])
}

approach1 <- function() {
  example_data %>% 
  mutate(first_positive_score1 = map_int(data, ~get_field(., "is_first_positive", score_1)),
         first_positive_score2 = map_int(data, ~get_field(., "is_first_positive", score_2)))
}

approach2 <- function() {
  example_data %>% 
    mutate(first_positive_score1 = map_dbl(data, get_field2, "is_first_positive", "score_1"),
           first_positive_score2 = map_dbl(data, get_field2, "is_first_positive", "score_2"))
}

library(microbenchmark)
microbenchmark(approach1(), approach2())
#> Unit: milliseconds
#>         expr       min        lq      mean    median        uq       max neval
#>  approach1() 19.849982 24.047509 26.470304 25.001731 26.896622 95.951980   100
#>  approach2()  2.159769  2.587905  2.783555  2.648321  2.740863  7.620581   100

1. Спасибо! Я должен был сказать в своем сообщении, но есть несколько разных логических столбцов (например, last_positive, first_negative_after_positive и т. Д.), Поэтому подход разделения / рекомбинации работает хорошо, но для этого требуется много кода. Это определенно план B, если я не смогу найти другой способ.

2. понял. Я отредактировал сообщение, чтобы показать, что упрощение вашей guess_field функции дает улучшение в 10 раз (для этого небольшого набора данных).

3. спасибо — дало хорошее увеличение скорости, но все равно заняло> 20 минут. Я думаю, что проблема заключается в большом количестве извлекаемых столбцов.

4. К сожалению, я не думаю, что есть волшебный соус. Держу пари, вы получите как минимум 100-кратное улучшение, перейдя к альтернативной стратегии. В противном случае, я не думаю, что есть способ улучшить ваш map get_field подход . В конце концов, там всего около 3 операций. Просто не так много возможностей для улучшения.

Ответ №2:

Если вы можете простить длинные строки, вы можете использовать map() следующим образом.

 library(dplyr)
library(tibble)
library(purrr)

example_data %>%
  mutate(score_1 = as.double(map(data, ~ deframe(.x[2])[which(deframe(.x[1]) == TRUE)])),
         score_2 = as.double(map(data, ~ deframe(.x[3])[which(deframe(.x[1]) == TRUE)]))) 

#   patient data             score_1 score_2
#   <chr>   <list>             <dbl>   <dbl>
# 1 A       <tibble [3 × 3]>      16      76
# 2 B       <tibble [3 × 3]>      17       5
# 3 C       <tibble [3 × 3]>      NA      NA