廿TT

譬如水怙牛過窓櫺 頭角四蹄都過了 因甚麼尾巴過不得

(googleAnalyticsR) 幾何分布回帰

あるセッション n のページ深度(pageDepth)k_n に対して, 適当な説明変数 x_n を用いて幾何分布を当てはめる。

\displaystyle \Pr(X_n = k_n) = p_n(1-p_n)^{k_n-1}
\displaystyle p_n={\rm logit}^{-1}(x_n \beta)
\displaystyle {\rm logit}^{-1}(\alpha)=\frac {1}{1+ \exp(-\alpha )}

どういうユーザー層がセッションから離脱しやすいかわかります。

最尤推定のための関数はこう。

geomreg <- function(formula,weights,data){
  mf <-model.frame(formula = formula, data = data)
  y <-model.extract(mf,"response")-1
  X <-model.matrix(formula,data = data)
  w <-data[,weights]
  ll <- function(beta,y,X,w){
    prob <- plogis(X %*% beta)
    sum(w*dgeom(y,prob = prob,log = TRUE))
  }
  ini <-numeric(ncol(X))
  names(ini) <- colnames(X)
  opt <-optim(ini,fn = ll,control = list(fnscale=-1,maxit=5000),
              y=y,X=X,w=w,hessian = TRUE)
  fitted <-plogis(X%*%opt$par)
  list(fitted=fitted,opt=opt)
}

尤度 ll だけ書いて、あとは optim に丸投げ。
この技は非常によく使います。

説明変数に userGender と userAgeBracket を使うことにして当てはまりを確認。

library(googleAnalyticsR)
library(tidyverse)
#####
ga_auth()
account_list <- ga_account_list()
ga_id <- account_list$viewId[3]

gadata <-
  google_analytics(ga_id,
                   date_range = c("2018-01-01","2018-06-30"),
                   metrics = c("sessions"),
                   dimensions = c("pageDepth","userGender","userAgeBracket"))

gadata2 <- gadata %>% 
  mutate(pageDepth=as.integer(pageDepth))
  
fit <-geomreg(pageDepth~userGender+userAgeBracket,weights = "sessions",data = gadata2)

gadata_fit <-gadata2 %>% 
  group_by(userGender,userAgeBracket) %>% 
  mutate(N=sum(sessions)) %>% 
  ungroup() %>% 
  mutate(pred=N*dgeom(x = pageDepth-1, prob = fit$fitted))

ggplot(gadata_fit,aes(x=pageDepth,y=sessions))+
  geom_col(fill="white",colour="black")+
  geom_point(aes(y=pred))+
  facet_wrap(~userGender+userAgeBracket,scales = "free_y")

f:id:abrahamcow:20180701052332p:plain

回帰係数の確認。エラーバーは2×標準誤差です。

dfcoef<-data.frame(beta=fit$opt$par,se=sqrt(diag(-solve(fit$opt$hessian)))) %>% 
  rownames_to_column()

ggplot(dfcoef,aes(x=rowname,y=beta,ymin=beta-2*se,ymax=beta+2*se))+
  geom_pointrange()+
  geom_hline(yintercept = 0,linetype=2)+
  coord_flip()

f:id:abrahamcow:20180701052419p:plain

一番離脱しにくいのは25〜34歳の男性。予想通り。