Создание функции рекламы / переноса для данных панели

Question

Я работаю над моделью Marketing Mix с данными поперечного сечения и пытаюсь подобрать функцию, которая применила бы преобразование AdStock / decay для каждой единицы отдельно.

Преобразование рекламного материала предполагает, что реклама не влияет на клиентов сразу, а распространяется во времени.Например: если мы генерируем 100 GRP на неделе 1, а коэффициент спада равен 0,5, только 50 будут влиять на продажи на неделе 1, 25 на неделе 2, 12,5 на неделе 3 и так далее.

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

# Preparing some data

dt1 <- data.frame(time = c(1:8), var = c(100,0,0,0,200,0,0,0))

# defining AdStock rate

adstock_rate <- 0.5

# A loop for adstocked variable

for (i in 1:length(dt1$var)){

  if (i == 1) {
    dt1$adstocked_advertising[i] = dt1$var[i] * adstock_rate }

  else {


    dt1$adstocked_advertising[i] = adstock_rate * dt1$var[i] + (1 - adstock_rate) * dt1$adstocked_advertising[i-1]
  } }

И результат будет

  time var adstocked_advertising
1    1 100              50.00000
2    2   0              25.00000
3    3   0              12.50000
4    4   0               6.25000
5    5 200             103.12500
6    6   0              51.56250
7    7   0              25.78125
8    8   0              12.89062

Как я могу написать функцию, которая будет работать в случае данных поперечного сечения?Например, в этом наборе данных:

# Cross-sectional data

dt <- data.frame(location = rep(letters[1:2], each = 4), time = rep(1:4, 2), var = c(100,0,0,0,200,0,0,0))

# Data Frame

  location time var
1        a    1 100
2        a    2   0
3        a    3   0
4        a    4   0
5        b    1 200
6        b    2   0
7        b    3   0
8        b    4   0

Теперь мне нужно написать функцию AdstockTransform (var, adstock_rate), которая применила бы цикл из первого примера к каждому местоположению отдельно.Это важно, так как параметр adstock_rate должен быть оптимизирован такими методами, как nlsLM.

Я был бы очень признателен за помощь.

РЕДАКТИРОВАТЬ: Спасибо, Парфе, ваше решение очень помогает.Как вы думаете, возможно ли использовать его как одну функцию?Я попытаюсь объяснить, почему это так важно для полурешения с использованием функции фильтра.

library(bayesm)
library(minpack.lm)
library(dplyr)

data(cheese)

# Function that describes both the AdStock and diminishing returns

adstockTransform <- function(x, as, beta){
  stats::filter( 1/(1+exp(-beta*x)), as, method = "recursive")
}

mmm.data <- cheese %>%
  group_by(RETAILER) %>%
  mutate(log.volume = log(VOLUME), log.price = log(PRICE), adstock= adstockTransform(DISP, as, beta))

# Optimization of the parameters

fit <- nlsLM(log.volume ~  const + B1*adstockTransform(DISP, as, beta) + B2*log.price,
             start = c(const = 10, B1 = 0.5, as = 0.2, beta = 2, B2 = -3),
             lower = c(const = 5, B1 = 0.2, as = 0.1, beta = 1.5, B2 = -5),
             upper = c(const = 12, B1 = 2, as = 0.4, beta = 6, B2 = -2),
             data=mmm.data)

summary(fit)

# Output

Formula: log.volume ~ const + B1 * adstockTransform(DISP, as, beta) + 
    B2 * log.price

Parameters:
      Estimate Std. Error t value Pr(>|t|)    
const  9.77943    0.11588  84.392  < 2e-16 ***
B1     0.40081    0.11288   3.551 0.000387 ***
as     0.40000    0.12625   3.168 0.001542 ** 
beta   6.00000    2.86959   2.091 0.036583 *  
B2    -2.00000    0.05896 -33.923  < 2e-16 ***
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 0.7709 on 5550 degrees of freedom

Number of iterations to convergence: 3 
Achieved convergence tolerance: 1.49e-08

Конечно - чтобы найти наилучшие параметры, скажем, для модели с фиксированными эффектами, мне следуетунижать данные перед оптимизацией;но это простой пример.

Несмотря на то, что функция фильтра полезна, она имеет два основных недостатка:

1) Использование этого трудно оправдать в случае моделирования переменной продаж.Геометрический распад подходит для других переменных - например, узнаваемость бренда - гораздо лучше

2) Невозможно закодировать его с помощью пакета brms

Конечно, он почти идеально соотносится с «желаемым» рекламным материаломтрансформации, но было бы здорово пропустить этот дополнительный фильтр -> шаг рекламы.

Answer 1

Рассмотрим by для подстановки ваших данных по местоположению и выполнения необходимых вычислений с помощью определенной функции, затем rbind всех объектов фрейма данных:

# Preparing some data
dt <- data.frame(location = rep(letters[1:2], each = 4), 
                 time = rep(1:4, 2), 
                 var = c(100,0,0,0,200,0,0,0))

# defining AdStock rate
adstock_rate <- 0.5

# define function to calculate column
calc_decay <- function(sub) {    
   # A loop for adstocked variable
   for (i in 1:length(sub$var)){
     if (i == 1) { sub$adstocked_advertising[i] <- sub$var[i] * adstock_rate }
     else { sub$adstocked_advertising[i] <- sub$var[i] * adstock_rate + 
                                             (1 - adstock_rate) * sub$adstocked_advertising[i-1] }
  }    
  return(sub)
}

# by call
df_list <- by(dt1, dt1$Location, calc_decay)

# rbind all elements    
final_df <- do.call(rbind, df_list)

Окончательный вывод

final_df

#   location time var adstocked_advertising
# 1        a    1 100                 50.00
# 2        a    2   0                 25.00
# 3        a    3   0                 12.50
# 4        a    4   0                  6.25
# 5        b    1 200                100.00
# 6        b    2   0                 50.00
# 7        b    3   0                 25.00
# 8        b    4   0                 12.50