Взвешенное скользящее среднее по дате R

Question

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

Если это возможно:

• ближайшие 2 события по дате будут иметь вес .50 (50%)
• 2-ые ближайшие даты будут иметьвес .30 (30%)
• самый дальний будет иметь вес .20 (20%).

Есть два способа создания скользящего среднего ниже one_df и two_df, я использую первый в моем реальном сценарии, но я добавил второй в случае, если было бы легче записать ввесовые функции.

library(dplyr)
library(lubridate)

# Create DataFrame


df<- data.frame(name=c('CAREY.FAKE','CAREY.FAKE','CAREY.FAKE','CAREY.FAKE','CAREY.FAKE','CAREY.FAKE','CAREY.FAKE',
                       'JOHN.SMITH','JOHN.SMITH','JOHN.SMITH','JOHN.SMITH','JOHN.SMITH','JOHN.SMITH','JOHN.SMITH',
                       'JEFF.JOHNSON','JEFF.JOHNSON','JEFF.JOHNSON','JEFF.JOHNSON','JEFF.JOHNSON','JEFF.JOHNSON','JEFF.JOHNSON',
                       'SARA.JOHNSON','SARA.JOHNSON','SARA.JOHNSON','SARA.JOHNSON','SARA.JOHNSON','SARA.JOHNSON','SARA.JOHNSON'
),
GA=c(3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20),
SV=c(3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20),
GF=c(3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20),
SA=c(3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20,3,2,1,1,2,3,20),
date=c("10/20/2016","10/19/2016","10/18/2016","10/17/2016","10/16/2016","10/15/2016","10/14/2016",
       "10/20/2016","10/19/2016","10/18/2016","10/17/2016","10/16/2016","10/15/2016","10/14/2016",
       "10/20/2016","10/19/2016","10/18/2016","10/17/2016","10/16/2016","10/15/2016","10/14/2016",
       "10/20/2016","10/19/2016","10/18/2016","10/17/2016","10/16/2016","10/15/2016","10/14/2016"
),
stringsAsFactors = FALSE)

one_df <- df %>%
  group_by(name) %>%
  arrange(name, mdy(date)) %>% 
  summarise_at(2:5, funs(mean(tail(., 6))))

two_df <- df %>% 
  group_by(name) %>%
  top_n(mdy(date), n = 6) %>%
  summarise_at(2:5, mean)

DF:

    name        GA  SV  GF  SA  date
CAREY.FAKE      3   3   3   3   10/20/2016
CAREY.FAKE      2   2   2   2   10/19/2016
CAREY.FAKE      1   1   1   1   10/18/2016
CAREY.FAKE      1   1   1   1   10/17/2016
CAREY.FAKE      2   2   2   2   10/16/2016
CAREY.FAKE      3   3   3   3   10/15/2016
CAREY.FAKE      20  20  20  20  10/14/2016
JOHN.SMITH      3   3   3   3   10/20/2016
JOHN.SMITH      2   2   2   2   10/19/2016
JOHN.SMITH      1   1   1   1   10/18/2016
JOHN.SMITH      1   1   1   1   10/17/2016
JOHN.SMITH      2   2   2   2   10/16/2016
JOHN.SMITH      3   3   3   3   10/15/2016
JOHN.SMITH      20  20  20  20  10/14/2016
JEFF.JOHNSON    3   3   3   3   10/20/2016
JEFF.JOHNSON    2   2   2   2   10/19/2016
JEFF.JOHNSON    1   1   1   1   10/18/2016
JEFF.JOHNSON    1   1   1   1   10/17/2016
JEFF.JOHNSON    2   2   2   2   10/16/2016
JEFF.JOHNSON    3   3   3   3   10/15/2016
JEFF.JOHNSON    20  20  20  20  10/14/2016
SARA.JOHNSON    3   3   3   3   10/20/2016
SARA.JOHNSON    2   2   2   2   10/19/2016
SARA.JOHNSON    1   1   1   1   10/18/2016
SARA.JOHNSON    1   1   1   1   10/17/2016
SARA.JOHNSON    2   2   2   2   10/16/2016
SARA.JOHNSON    3   3   3   3   10/15/2016
SARA.JOHNSON    20  20  20  20  10/14/2016

РЕЗУЛЬТАТЫ:

name            GA  SV  GF  SA
CAREY.FAKE      2   2   2   2
JEFF.JOHNSON    2   2   2   2
JOHN.SMITH      2   2   2   2
SARA.JOHNSON    2   2   2   2

ОЖИДАЕМЫЕ РЕЗУЛЬТАТЫ:

name             GA   SV    GF   SA
CAREY.FAKE      2.05 2.05  2.05 2.05
JEFF.JOHNSON    2.05 2.05  2.05 2.05
JOHN.SMITH      2.05 2.05  2.05 2.05
SARA.JOHNSON    2.05 2.05  2.05 2.05

Answer 1

Кажется, есть простое решение, просто добавив исходные коды:

w <- rev(c(.5,.5,.3,.3,.2,.2))

# one_df
df %>%
  group_by(name) %>%
  arrange(name, mdy(date)) %>% 
  summarise_at(2:5, funs(weighted.mean(tail(., 6),w)))

## A tibble: 4 x 5
#  name            GA    SV    GF    SA
#  <chr>        <dbl> <dbl> <dbl> <dbl>
#1 CAREY.FAKE    2.05  2.05  2.05  2.05
#2 JEFF.JOHNSON  2.05  2.05  2.05  2.05
#3 JOHN.SMITH    2.05  2.05  2.05  2.05
#4 SARA.JOHNSON  2.05  2.05  2.05  2.05

#two_df
df %>% 
  group_by(name) %>%
  top_n(mdy(date), n = 6) %>%
  summarise_at(2:5,function(x) weighted.mean(x,w))
## A tibble: 4 x 5
#  name            GA    SV    GF    SA
#  <chr>        <dbl> <dbl> <dbl> <dbl>
#1 CAREY.FAKE    2.05  2.05  2.05  2.05
#2 JEFF.JOHNSON  2.05  2.05  2.05  2.05
#3 JOHN.SMITH    2.05  2.05  2.05  2.05
#4 SARA.JOHNSON  2.05  2.05  2.05  2.05

Answer 2

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

weights <- c(.5,.5,.3,.3,.2,.2)
df %>% 
  group_by(name) %>%
  arrange(desc(date)) %>% # sort dates ...
  slice(1:6) %>%          # ... in order to keep only 6 most recent
  summarise_at(vars(-date,-name),
               ~sum(.*weights)/sum(weights)) # apply weighted average
# # A tibble: 4 x 5
#   name            GA    SV    GF    SA
#   <chr>        <dbl> <dbl> <dbl> <dbl>
# 1 CAREY.FAKE    2.05  2.05  2.05  2.05
# 2 JEFF.JOHNSON  2.05  2.05  2.05  2.05
# 3 JOHN.SMITH    2.05  2.05  2.05  2.05
# 4 SARA.JOHNSON  2.05  2.05  2.05  2.05

Answer 3

Здесь вы также можете увидеть вес, если вы выполняете часть кода.По сути, он делает то же самое, что и ответ выше.

df <- df %>% mutate(distance_to_today = today() - as.Date(date, tryFormats = c("%m/%d/%Y")) )  %>% 
arrange(name, distance_to_today) %>% 
group_by(name) %>%  mutate(rank=rank(distance_to_today)) %>% 
mutate(weight=ifelse(rank<=2,0.5,ifelse(rank<=4,0.3,ifelse(rank<=6,0.2,0)))) %>% 
group_by(name) %>% summarise(GA=sum(GA*weight)/sum(weight), 
SV=sum(SV*weight)/sum(weight), GF=sum(GF*weight)/sum(weight), 
SA=sum(SA*weight)/sum(weight))

Answer 4

Получить ваш результат можно с помощью функции взвешенного скользящего среднего WMA из пакета TTR.Веса применяются к записям записей, выбранным для длины периода (n = 6).Вес должен быть такой же длины, как период.

library(dplyr)
library(lubridate)
library(purrr)

df %>% 
  group_by(name) %>%
  arrange(name, mdy(date)) %>% 
  mutate_at(2:5, TTR::WMA, n = 6, wts = c(.2, .2, .3, .3, .5, .5))

# A tibble: 28 x 6
# Groups:   name [4]
   name            GA    SV    GF    SA date      
   <chr>        <dbl> <dbl> <dbl> <dbl> <chr>     
 1 CAREY.FAKE   NA    NA    NA    NA    10/14/2016
 2 CAREY.FAKE   NA    NA    NA    NA    10/15/2016
 3 CAREY.FAKE   NA    NA    NA    NA    10/16/2016
 4 CAREY.FAKE   NA    NA    NA    NA    10/17/2016
 5 CAREY.FAKE   NA    NA    NA    NA    10/18/2016
 6 CAREY.FAKE    3.50  3.50  3.50  3.50 10/19/2016
 7 CAREY.FAKE    2.05  2.05  2.05  2.05 10/20/2016
 8 JEFF.JOHNSON NA    NA    NA    NA    10/14/2016
 9 JEFF.JOHNSON NA    NA    NA    NA    10/15/2016
10 JEFF.JOHNSON NA    NA    NA    NA    10/16/2016
# ... with 18 more rows

Или с отфильтрованным NA:

df %>% 
  group_by(name) %>%
  arrange(name, mdy(date)) %>% 
  mutate_at(2:5, TTR::WMA, n = 6, wts = c(.2, .2, .3, .3, .5, .5)) %>% 
  filter(!is.na(GA))

# A tibble: 8 x 6
# Groups:   name [4]
  name            GA    SV    GF    SA date      
  <chr>        <dbl> <dbl> <dbl> <dbl> <chr>     
1 CAREY.FAKE    3.50  3.50  3.50  3.50 10/19/2016
2 CAREY.FAKE    2.05  2.05  2.05  2.05 10/20/2016
3 JEFF.JOHNSON  3.50  3.50  3.50  3.50 10/19/2016
4 JEFF.JOHNSON  2.05  2.05  2.05  2.05 10/20/2016
5 JOHN.SMITH    3.50  3.50  3.50  3.50 10/19/2016
6 JOHN.SMITH    2.05  2.05  2.05  2.05 10/20/2016
7 SARA.JOHNSON  3.50  3.50  3.50  3.50 10/19/2016
8 SARA.JOHNSON  2.05  2.05  2.05  2.05 10/20/2016

РЕДАКТИРОВАТЬ:

Если не хватает значений для окна периода, мы можем создать функцию иоберните это в функцию мурлыкания possible, чтобы вернуть NA, когда функция завершается ошибкойВ приведенном ниже примере я удалил 2 записи из «CAREY.FAKE», чтобы показать результат.

my_func <- function(x){
  TTR::WMA(x, n = 6, wts = c(.2, .2, .3, .3, .5, .5))
}

df %>% 
  group_by(name) %>%
  arrange(name, mdy(date)) %>% 
  mutate_at(2:5, possibly(my_func, otherwise = NA_real_))

# A tibble: 26 x 6
# Groups:   name [4]
   name            GA    SV    GF    SA date      
   <chr>        <dbl> <dbl> <dbl> <dbl> <chr>     
 1 CAREY.FAKE      NA    NA    NA    NA 10/14/2016
 2 CAREY.FAKE      NA    NA    NA    NA 10/15/2016
 3 CAREY.FAKE      NA    NA    NA    NA 10/16/2016
 4 CAREY.FAKE      NA    NA    NA    NA 10/17/2016
 5 CAREY.FAKE      NA    NA    NA    NA 10/18/2016
 6 JEFF.JOHNSON    NA    NA    NA    NA 10/14/2016
 7 JEFF.JOHNSON    NA    NA    NA    NA 10/15/2016
 8 JEFF.JOHNSON    NA    NA    NA    NA 10/16/2016
 9 JEFF.JOHNSON    NA    NA    NA    NA 10/17/2016
10 JEFF.JOHNSON    NA    NA    NA    NA 10/18/2016
# ... with 16 more rows