Очистите столбец данных с нулевыми значениями, подставив коэффициент на основе итоговых условий

Question

Прошу прощения за неясный заголовок, но я не совсем уверен, как лучше объяснить проблему словами, и вместо этого попробую использовать пример. Я работаю с набором данных баскетбола, где определенные строки в столбце позиции имеют NA. Я хотел бы обновить столбец позиции с позицией с ближайшей средней высотой в этой позиции за этот год. Вот примерный фрейм данных:

df_player <- data.frame(id = 1:100, 
                        year = floor(runif(100,2000,2006)), 
                        height = runif(100,70,85), 
                        pos = sample(c("G","F","C",NA), size = 100, replace = TRUE))

Я также создал фрейм данных средних высот для каждой позиции и каждого года для простоты объяснения моего идеального решения. Я не собираюсь формировать этот фрейм данных в решении, я просто предоставляю его, чтобы помочь объяснить, что решение должно было бы сделать.

df_avg <- df_player%>%
  filter(!is.na(pos))%>%
  group_by(year, pos)%>%
  summarize(avg_height = mean(height))

Для каждого игрока с отсутствующей позицией в df_player я бы сначала хотел сопоставить год пропавшего игрока с годом в df_avg. Затем сравните рост игрока со средним ростом для каждой позиции в этом году. Используя эти сравнения, я мог бы затем заполнить NA положением, которое соответствует средней позиции, ближайшей к высоте. Я бы предпочел не делать этого с соединениями. Пример на словах:
- Игрок был составлен в 2003 году, но в нем отсутствуют данные о позиции. Рост игрока составляет 73.
-Средние высоты для охранников, нападающих и центров ("G", "F", "C") в 2003 году составляли 70, 72 и 76 соответственно.
- Позиция для игрока в 2003 году будет обновлена ​​до форварда («F»).

Я решил аналогичную проблему с данными цифр c, используя tidyverse group by и mutate. Если высота отсутствовала, решение показано ниже.

df_player%>%
group_by(year)%>%
  mutate(height = case_when(is.na(height)~median(height, na.rm = TRUE),TRUE~height))

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

Answer 1

Вот один из способов использования dplyr и серии соединений:

library(dplyr)

df_player %>%
  filter(is.na(pos)) %>%
  left_join(df_avg, by = 'year') %>%
  group_by(id) %>%
  mutate(pos.x = pos.y[which.min(abs(height - avg_height))]) %>%
  filter(!duplicated(id)) %>%
  right_join(df_player) %>%
  mutate(pos = coalesce(pos, pos.x)) %>%
  select(-pos.x, -pos.y, -avg_height)


#      id  year height pos  
#   <int> <dbl>  <dbl> <fct>
# 1     1  2001   74.9 F    
# 2     2  2001   75.8 F    
# 3     3  2003   70.6 G    
# 4     4  2000   75.4 C    
# 5     5  2002   78.6 F    
# 6     6  2002   80.3 G    
# 7     7  2004   84.6 C    
# 8     8  2002   80.5 F    
# 9     9  2003   70.2 C    
#10    10  2001   78.0 F    
# … with 90 more rows

data

set.seed(100)
df_player <- data.frame(id = 1:100, 
                        year = floor(runif(100,2000,2006)), 
                        height = runif(100,70,85), 
                        pos = sample(c("G","F","C",NA), size = 100, replace = TRUE))

Answer 2

Функция lapply фильтрует кадр данных о средней высоте по годам и находит положение с минимальной абсолютной разницей между ростом игроков и средним. Если позиция отсутствует, то она обновляется с ближайшей позицией от y.

library(dplyr)

df_avg <- mutate(df_avg, pos = as.character(pos))

df_player <- df_player %>%
  as_tibble() %>%
  mutate(id = 1:nrow(df_player),
         pos = as.character(pos)) %>%
  split(.$id) %>%
  lapply(function(x, ref) {

    y <- ref %>%
      as_tibble() %>%
      filter(year == x$year) %>%
      mutate(diff = abs(ref[ref$year == x$year, ]$avg_height - as.numeric(x$height))) %>%
      top_n(1, desc(diff))

    mutate(x, pos = ifelse(is.na(pos), y$pos, pos))

  }, ref = df_avg) %>%
  bind_rows() %>%
  select(-id)

Обновление

Это вычисляет и применяет средства в пределах lapply.

library(dplyr)

df_player <- tibble(id = 1:100, 
                        year = floor(runif(100,2000,2006)), 
                        height = runif(100,70,85), 
                        pos = sample(c("G","F","C",NA), size = 100, replace = TRUE))

df_player %>%
  mutate(id = 1:nrow(df_player)) %>%
  split(.$id) %>%
  lapply(function(x, ref) {

    y <- ref %>%
      filter(year == x$year,
             !is.na(pos)) %>%
      group_by(pos) %>%
      summarise(avg_height = mean(height, na.rm = TRUE)) %>%
      mutate(diff = abs(avg_height - as.numeric(x$height))) %>%
      top_n(1, desc(diff))

    mutate(x, pos = ifelse(is.na(pos), y$pos, pos))

  }, ref = df_player) %>%
  bind_rows() %>%
  select(-id)