宇崎ちゃん献血コラボ効果の推定

note.com

SCMについて調べてないのです。 私の知ってる範囲ではおそらく状態空間で季節調整して

mu_t~mu_t-1+promotion+season+log(県の対象人数)

y_t~N(mu_t,sigma)

みたいにやるのが良い気がします。

状態空間×ベイズが素晴らしいのはわかりますが面倒なので、１０月のみのデータをつかって雑に

献血人数=対象人数献血率(1+プロモーション）

n10=poplationp(1+prom)

つまり献血する確率がプロモーションで変化すると仮定してpromとpを推定してみました。

res.lm=lm(logn10~lpop+intv,df)
summary(res.lm)
            Estimate Std. Error t value Pr(>|t|)    
(Intercept) -16.25594    1.53519 -10.589 3.61e-13 ***
lpop          1.16072    0.07406  15.674  < 2e-16 ***
intv          0.01547    0.16082   0.096    0.924    

しかし、logをとって計算したモデルだとイベント効果がユーイにならない。(推定値はexpをとって1.02で2%程度あがった事になる）

logをとらないで直接非線形回帰すると

Parameters:
    Estimate Std. Error t value Pr(>|t|)    
p0 0.0031953  0.0001349   23.68   <2e-16 ***
intv  0.1282530  0.0593745    2.16   0.0367 *  

と、つまり１ヶ月に献血する確率は0.3%,プロモーションにより13%程度増えた事になります。

ちなみに、このプロモーションの交絡は無いと思うのですがどーでしょう。 中間効果はバズったので、バッチリあるハズです。

library(openxlsx)

df <- read.xlsx("~/Downloads/Dataset_SCMuzaki.xlsx", sheet = 1)

kanto=df[44,]
ts.plot(c(unlist(kanto[,5:ncol(df)])))

#10月から

df=df[1:43,]
kanto=df[df$intv==1,]
nonkanto=df[df$intv==0,]

df=rbind(kanto,nonkanto)


df$logn10=log(df$n10)

df$lpop=log(1000*df$pop15to64)


res.nls=nls(n10~pop15to64*p0*(1+b*intv),df,c(p0=0.01,b=0.001))
res.nls_non=nls(n10~pop15to64*p0,df,c(p0=0.01))

> sd(resid(res.nls_non))
[1] 1327.848
> sd(resid(res.nls))
[1] 1299.451