euclid/acr_calculations.R at master · wal/euclid · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
simple_rolling_average_coupled <- function(data, metric, acute_period, chronic_period) {
  data %>%
    mutate(
      acute = rollapply(data[,metric], acute_period, FUN = mean, na.rm = TRUE, fill = NA, align = "right"),
      chronic = rollapply(data[,metric], chronic_period, FUN = mean, na.rm = TRUE, fill = NA, align = "right"),
      acr = acute / chronic) %>%
    gather(statistic, value, acute, chronic, acr)
}

simple_rolling_average_uncoupled <- function(data, metric, acute_period, chronic_period) {
  data %>%
    mutate(
      acute = rollapply(data[,metric], acute_period, FUN = mean, na.rm = TRUE, fill = NA, align = "right"),
      chronic = rollapply(data[,metric], c(list(-acute_period:-(chronic_period+acute_period)), -chronic_period), FUN = mean, na.rm = TRUE, fill = NA, align = "right"),
      acr = acute / chronic) %>%
    gather(statistic, value, acute, chronic, acr)
}

ewma_coupled <- function(data, metric, acute_period, chronic_period) {
  acute_alpha <- 2/(acute_period+1)
  chronic_alpha <- 2/(chronic_period+1)

  data$acute <- NA
  data$chronic <- NA

  data$acute[1] <- data[[metric]][1]
  data$chronic[1] <- data[[metric]][1]

  for(i in (2:dim(data)[1])){
    data$acute[i] <- data[[metric]][i] * acute_alpha + (1-acute_alpha) * data$acute[i-1]
    data$chronic[i] <- data[[metric]][i] * chronic_alpha + (1-chronic_alpha) * data$chronic[i-1]
  }

  data %>%
    mutate(
      acr = acute / chronic) %>%
    gather(statistic, value, acute, chronic, acr)
}

ewma_uncoupled <- function(data, metric, acute_period, chronic_period) {
  acute_alpha <- 2/(acute_period+1)
  chronic_alpha <- 2/(chronic_period+1)

  data$acute <- NA
  data$chronic <- NA

  data$acute[1] <- data[[metric]][1]
  data$chronic[1:7] <- mean(data[[metric]][1:7])

  for(i in (2:dim(data)[1])){
    data$acute[i] <- data[[metric]][i] * acute_alpha + (1-acute_alpha) * data$acute[i-1]
    if(i > 7) {
      data$chronic[i] <- data[[metric]][i-7] * chronic_alpha + (1-chronic_alpha) * data$chronic[i-7]
    }
  }

  data %>%
    mutate(
      acr = acute / chronic) %>%
    gather(statistic, value, acute, chronic, acr)
}