Как в R передать вам параметры, заданные в одном столбце, для выполнения операций над другим? - PullRequest
Новая
       15

Как в R передать вам параметры, заданные в одном столбце, для выполнения операций над другим?

0 голосов
/ 23 марта 2020

Я собираюсь сохранить некоторые параметры в одной таблице и использовать эту информацию для агрегирования значений, связанных с отзывчивыми строками из другого набора данных. Таким образом, в приведенном ниже примере настройки возвращаемое значение для p1 будет представлять собой сумму значений всех записей в data_tibble, где число = 123, а коды являются либо «code1», либо «code2» *, а значение даты равно 2020-01- 01. И так далее для p2.

Я не знаю, как это сделать; Я пытался создать функцию, используя apply и отдельно, чтобы просто создать функцию, которая будет запускаться сама и генерировать вектор результатов (как показано ниже в функции не работает).

Любая помощь приветствуется!

Отредактировано, чтобы исправить опечатку

* Здесь это немного глупо, но у меня есть сотни различных кодов, с которыми приходится иметь дело, и в некоторых случаях будет легче исключить все, кроме нескольких, в то время как в в других случаях будет лучше просто включить горстку и т. д. c. Так что NULL, или возможность передачи, помещают в список что-то, что приведет к передаче всех записей, было бы идеально. 

library(tidyverse)
library(lubridate)
#Set up Parameters
parameters_tibble <- tibble(name = character(),
                               number = numeric(),
                               acceptable_codes = list(),
                               unacceptable_codes = list(),
                               cutoff_date = date(),
                               .rows = NULL)
parameters_tibble$date <- as_date(parameters_tibble$date)

parameters_tibble <- add_row(parameters_tibble,
                             name = "param1",
                             number = 123,
                             acceptable_codes = list(c("code1", "code2")),
                             unacceptable_codes = list(NULL),
                             cutoff_date = as_date("2020-01-01"))

parameters_tibble <- add_row(parameters_tibble,
                             name = "param2",
                             number = 456,
                             acceptable_codes = list(NULL),
                             unacceptable_codes = list("code72"),
                             cutoff_date = as_date("2020-01-01"))

#Create sample dataset
data_tibble <- tibble(number = numeric(),
                      code = character(),
                      date = date(),
                      value = numeric(),
                      .rows=NULL)
data_tibble$date <- as_date(data_tibble$date)
data_tibble <- add_row(data_tibble,
                       number = rep(c(123,456),6),
                       code = rep(c("code1", "code2", "code3", "code4"),3),
                       date = as_date(rep(c("2020-01-01","2019-11-01"),6)),
                       value = rep(1:12))


doesnotwork <- function(dt = data_tibble, pt = parameters_tibble) {
  aggregatedValues <- dt %>% 
    sum(
      filter(number == pt$number &
               code %in% pt$acceptable_codes &
               !(code %in% pt$acceptable_codes) &
               date >= pt$cutoff_date) 
      $value)
  return(aggregatedValues)
}

1 Ответ

0 голосов
/ 23 марта 2020

Уф. Пожалуйста, сделайте воспроизводимый пример в следующий раз, например, используйте столбцы, которые присутствуют в ваших df (date - это не var в parameters_tibble, Std.Amt - это не столбец в data_tibble). Основываясь на вашем коде и описании, мой подход к вычислению агрегированных значений использует unnest, чтобы избавиться от столбцов списка (примечание: достаточно определить приемлемые коды), а затем использует соединение + некоторые дополнительные операторы фильтра для фильтрации ваших данных. тибл по параметрам тиббла. После этого шага легко вычислить агрегированные значения. Попробуйте это: 

library(tidyverse)
library(lubridate)

#Set up Parameters
parameters_tibble <- tibble(name = character(),
                            number = numeric(),
                            acceptable_codes = list(),
                            unacceptable_codes = list(),
                            cutoff_date = date(),
                            .rows = NULL)

parameters_tibble$cutoff_date <- as_date(parameters_tibble$cutoff_date)

parameters_tibble <- add_row(parameters_tibble,
                             name = "param1",
                             number = 123,
                             acceptable_codes = list(c("code1", "code2")),
                             unacceptable_codes = list(NULL),
                             cutoff_date = "2020-01-01")

parameters_tibble <- add_row(parameters_tibble,
                             name = "param2",
                             number = 456,
                             acceptable_codes = list(c("code1", "code2", "code3")),
                             unacceptable_codes = list("code4"),
                             cutoff_date = "2020-01-01")

# Unnest: One row for each acceptable code
parameters_tibble_unnest <- parameters_tibble %>% 
  unnest(c(acceptable_codes, unacceptable_codes))

#Create sample dataset
data_tibble <- tibble(number = numeric(),
                      code = character(),
                      date = date(),
                      value = numeric(),
                      .rows=NULL)

data_tibble$date <- as_date(data_tibble$date)

data_tibble <- add_row(data_tibble,
                       number = rep(c(123,456),6),
                       code = rep(c("code1", "code2", "code3", "code4"),3),
                       date = as_date(rep(c("2020-01-01","2019-11-01"),6)),
                       value = rep(1:12))

# Filter using joins
df_join <- left_join(data_tibble, parameters_tibble_unnest, by = c("number", "code" = "acceptable_codes")) %>% 
  # Drop non-matching data-rows with no match in acceptable codes
  filter(!is.na(name)) %>% 
  # filter for cutoff-date
  filter(date >= cutoff_date) %>% 
  # filter for unacceptable_codes
  filter(!code %in% unacceptable_codes)

df_join
#> # A tibble: 3 x 7
#>   number code  date       value name   unacceptable_codes cutoff_date
#>    <dbl> <chr> <date>     <dbl> <chr>  <chr>              <date>     
#> 1    123 code1 2020-01-01     1 param1 <NA>               2020-01-01 
#> 2    123 code1 2020-01-01     5 param1 <NA>               2020-01-01 
#> 3    123 code1 2020-01-01     9 param1 <NA>               2020-01-01

aggregated_values <- df_join %>% 
  count(number, wt = value)
aggregated_values
#> # A tibble: 1 x 2
#>   number     n
#>    <dbl> <dbl>
#> 1    123    15

Обновление: добавление в функцию 

get_aggregated_values <- function(dt, pt) {
  # Unnest: One row for each acceptable and unacceptable code
  pt_unnest <- pt %>% 
    unnest(c(acceptable_codes, unacceptable_codes))

  # Join by number and code == acceptable_codes
  dt_join <- left_join(dt, pt_unnest, by = c("number", "code" = "acceptable_codes")) %>% 
    # Drop non-matching data-rows with no match in acceptable codes
    filter(!is.na(name)) %>% 
    # filter for cutoff-date
    filter(date >= cutoff_date) %>% 
    # filter for unacceptable_codes
    filter(!code %in% unacceptable_codes)

  aggregated_values <- dt_join %>% 
    count(number, wt = value)
  aggregated_values
}

get_aggregated_values(data_tibble, parameters_tibble)
#> # A tibble: 1 x 2
#>   number     n
#>    <dbl> <dbl>
#> 1    123    15

Создано в 2020-03-25 пакетом prex (v0 .3.0)

...