R/geog_predictions.R

In alexWhitworth/concord: Code for prediction of concord models

#' @title Prediction for each geography
#' @description Create point predictions and their standard errors for a a given geography
#' @param geography A character scalar. In: \code{c("usa", "can", "jap", "lt", "uk", "ger", "fra", "cmg", "iEUR")}.
#' @param dat A data environment with \code{data.frame}s for prediction.
#' @param mods A list of models for prediction
#' @return A \code{list} with predictions and standard errors for each revenue stream of the specified geography.
#' @export
geog_predictions <- function(geography, dat, mods) {
  pred_out <- list()
  
  if (geography == "usa") {
    #-----------------------------
    # USA
    #-----------------------------
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= mods$mod$phys, allow.new.levels= rep(TRUE, 3),
                             newdata.list= list(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ], 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]], mods$t_func[[3]]),
                             R.slope= rep("xmas", 3), level3= rep(FALSE, 3), usa= rep(TRUE, 3))
    # digital predictions
    pred_out[[2]] <- pred_se(obj.list= mods$mod$digi, allow.new.levels= rep(TRUE, 3),
                             newdata.list= list(dat$d[dat$d$d_tier == 1, ], dat$d[dat$d$d_tier == 2, ], 
                                                dat$d[dat$d$d_tier == 3, ]),
                             trans.func= list(mods$t_func[[4]], mods$t_func[[5]], mods$t_func[[6]]),
                             R.slope= rep("xmas", 3), level3= rep(FALSE, 3), usa= rep(TRUE, 3))
    # streaming predictions
    pred_out[[3]] <- pred_se(obj.list= mods$mod$stream, allow.new.levels= rep(TRUE, 3),
                             newdata.list= list(dat$s[dat$s$d_tier == 1, ], dat$s[dat$d$d_tier == 2, ], 
                                                dat$s[dat$s$d_tier == 3, ]),
                             trans.func= list(mods$t_func[[7]], mods$t_func[[8]], mods$t_func[[9]]),
                             R.slope= c("xmas", "xmas", "none"), level3= rep(FALSE, 3), usa= rep(TRUE, 3))
    names(pred_out) <- c("p", "d", "s")
    
  } else if (geography == "can") {
    #-----------------------------
    # CANADA
    #-----------------------------  
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= mods$mod$phys, allow.new.levels= rep(TRUE, 3),
                             newdata.list= list(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ], 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]], mods$t_func[[3]]),
                             R.slope= rep("none", 3), title= c(TRUE, FALSE, FALSE), level3= rep(FALSE, 3))
    # digital predictions
    pred_out[[2]] <- pred_se(obj.list= mods$mod$digi, allow.new.levels= rep(TRUE, 3),
                             newdata.list= list(dat$d[dat$d$d_tier == 1, ], dat$d[dat$d$d_tier == 2, ], 
                                                dat$d[dat$d$d_tier == 3, ]),
                             trans.func= list(mods$t_func[[4]], mods$t_func[[5]], mods$t_func[[6]]),
                             R.slope= c("none", "xmas", "xmas"), level3= rep(FALSE, 3))
    # streaming predictions
    pred_out[[3]] <- pred_se(obj.list= mods$mod$stream, allow.new.levels= rep(TRUE, 2),
                             newdata.list= list(dat$s[dat$s$d_tier == 1, ], 
                                                rbind(dat$s[dat$d$d_tier == 2, ], dat$s[dat$s$d_tier == 3, ])),
                             trans.func= list(mods$t_func[[7]], mods$t_func[[8]]),
                             R.slope= c("xmas", "mf_day"), level3= rep(FALSE, 2))
    names(pred_out) <- c("p", "d", "s")
    
  } else if (geography == "jap") {
    #-----------------------------
    # JAPAN
    #-----------------------------
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= mods$mod$phys, 
                             newdata.list= list(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ], 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]], mods$t_func[[3]]),
                             R.slope= c("none", "both", "none"), level3= rep(FALSE, 3))
    # digital predictions
    pred_out[[2]] <- pred_se(obj.list= mods$mod$digi, 
                             newdata.list= list(dat$d[dat$d$d_tier == 1, ], dat$d[dat$d$d_tier == 2, ], 
                                                dat$d[dat$d$d_tier == 3, ]),
                             trans.func= list(mods$t_func[[4]], mods$t_func[[5]], mods$t_func[[6]]),
                             R.slope= rep("none", 3), level3= rep(FALSE, 3))
    # streaming predictions
    pred_out[[3]] <- pred_se(obj.list= mods$mod$stream, 
                             newdata.list= list(dat$s[dat$s$d_tier == 1, ], dat$s[dat$d$d_tier == 2, ], 
                                                dat$s[dat$s$d_tier == 3, ]),
                             trans.func= list(mods$t_func[[7]], mods$t_func[[8]], mods$t_func[[9]]),
                             R.slope= rep("xmas", 3), level3= rep(FALSE, 3))  
    names(pred_out) <- c("p", "d", "s")
    
  } else if (geography == "cmg") {
    #-----------------------------
    # CMG
    #-----------------------------
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= mods$mod, 
                             newdata.list= list(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ], 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]], mods$t_func[[3]]),
                             R.slope= rep("xmas", 3), level3= rep(FALSE, 3))
    names(pred_out) <- c("p")
    
  } else if (geography == "fra") {
    #-----------------------------
    # FRANCE
    #-----------------------------
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= list(mods$mod[[1]], mods$mod[[2]]), 
                             newdata.list= list(rbind(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ]), 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]]),
                             R.slope= c("none", "none"), level3= c(FALSE, FALSE))
    # digital predictions
    pred_out[[2]] <- pred_se(obj.list= list(mods$mod[[3]]), 
                             newdata.list= list(rbind(dat$d[dat$d$d_tier == 1, ], dat$d[dat$d$d_tier == 2, ])), 
                             trans.func= list(mods$t_func[[3]]),
                             R.slope= "none", level3= FALSE)
    names(pred_out) <- c("p", "d")
    
  } else if (geography == "ger") {
    #-----------------------------
    # GERMANY
    #-----------------------------
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= list(mods$mod[[1]], mods$mod[[2]]), 
                             newdata.list= list(rbind(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ]), 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]]),
                             R.slope= c("none", "xmas"), level3= c(FALSE, FALSE))
    # digital predictions
    pred_out[[2]] <- pred_se(obj.list= list(mods$mod[[3]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[3]]),
                             R.slope= "none", level3= FALSE)
    # streaming predictions
    pred_out[[3]] <- pred_se(obj.list= list(mods$mod[[4]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[4]]),
                             R.slope= "none", level3= FALSE)  
    names(pred_out) <- c("p", "d", "s")
    
  } else if (geography == "iEUR") {
    #-----------------------------
    # iTUNES Europe
    #-----------------------------
    # digital predictions
    pred_out[[1]] <- pred_se(obj.list= list(mods$mod[[1]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[1]]),
                             R.slope= "none", level3= FALSE)
    # streaming predictions
    pred_out[[2]] <- pred_se(obj.list= list(mods$mod[[2]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[2]]),
                             R.slope= "mf_day", level3= FALSE)  
    names(pred_out) <- c("d", "s")
    
  } else if (geography == "lt") {
    #-----------------------------
    # LICENSED TERRITORIES
    #-----------------------------
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= list(mods$mod[[1]], mods$mod[[2]]), 
                             newdata.list= list(rbind(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ]), 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]]),
                             R.slope= c("none", "none"), level3= c(FALSE, FALSE))
    # digital predictions
    pred_out[[2]] <- pred_se(obj.list= list(mods$mod[[3]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[3]]),
                             R.slope= "none", level3= FALSE)
    # streaming predictions
    pred_out[[3]] <- pred_se(obj.list= list(mods$mod[[4]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[4]]),
                             R.slope= "none", level3= FALSE)  
    names(pred_out) <- c("p", "d", "s")
    
  } else if (geography == "uk") {
    #-----------------------------
    # UNITED KINGDOM
    #-----------------------------
    # physical predictions
    pred_out[[1]] <- pred_se(obj.list= list(mods$mod[[1]], mods$mod[[2]]), 
                             newdata.list= list(rbind(dat$p[dat$p$p_tier == 1, ], dat$p[dat$p$p_tier == 2, ]), 
                                                dat$p[dat$p$p_tier == 3, ]),
                             trans.func= list(mods$t_func[[1]], mods$t_func[[2]]),
                             R.slope= c("none", "none"), level3= c(FALSE, FALSE))
    # digital predictions
    pred_out[[2]] <- pred_se(obj.list= list(mods$mod[[3]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[3]]),
                             R.slope= "none", level3= FALSE)
    # streaming predictions
    pred_out[[3]] <- pred_se(obj.list= list(mods$mod[[4]]), 
                             newdata.list= list(dat$d[!is.na(dat$d$d_tier), ]),
                             trans.func= list(mods$t_func[[4]]),
                             R.slope= "none", level3= FALSE)  
    names(pred_out) <- c("p", "d", "s")
    
  } else if (geography == "ccr") {
    #-----------------------------
    # CCR
    #-----------------------------
    pred_out <- pred_se(obj.list= mods$mod, newdata.list= list(dat$p, dat$d, dat$s), allow.new.levels= rep(TRUE, 3),
                        trans.func= mods$t_fun, R.slope= rep("none", 3),
                        title= rep(TRUE, 3), level3= rep(TRUE, 3))
    names(pred_out) <- c("p", "d", "s")
    
  }
   
  return(pred_out)
}