R/baysian_sh.R

#' Bayesian Shrikage function
#'
#' A function of Bayesian shrinkage Estimator.
#'
#' @param lm.loop a list of lm_loop output.
#' @param lm.pool a list of lm_pool output.
#' @param data.sign a data.table class dataset contains coefficient sign check info.
#' @param is.signcheck TRUE turns on coefficient sign check.
#' @param coef.lower a numeric value of the lower bound of the coefficients after shrinkage to the gloable ones. If value is 0.5, then the lower bound is 50% of gloable. Default is 0.5.
#' @param coef.upper a numeric value of the uppper bound of the coefficients after shrinkage to the gloable ones. If value is 1.5, then the upper bound is 150% of gloable. Default is 1.5.
#'
#' @return a list of modeling result. It contains the following components:
#'    R2: a numeric of R2 from linear model.
#'    mape: a numeric of MAPE from linear model.
#'
#' @export
baysian_sh=function(lm.loop,lm.pool,data.sign,coef.lower=0.5,coef.upper=1.5,is.signcheck=T){
  require(data.table)
  ##################################################################################################
#   # bayesian shrinkage and sign check; output coef.post (coef by cross section)
#   lm.loop=fit.loop#result from lm_loop
#   lm.pool=fit#result from lm_pool
#   is.signcheck=F#whether do sign check
#   data.sign=data.sign#sign check dataset
  ##################################################################################################
  pool=as.data.table(lm.pool$coef,keep.rownames=T)[,c("rn","pool"),with=F]
  data.sign=copy(data.sign)
  setnames(data.sign,"var","rn")
  setnames(pool,"pool","overall")
  pool=merge(pool,data.sign,by="rn",all.x=T)
  coef.post=foreach(i=1:ncol(lm.loop$coef),.multicombine = T)  %do% {
    temp=as.data.table(lm.loop$fit[[i]]$coef,keep.rownames = T)
    temp=merge(temp,pool,by="rn",all.y = T)
    temp=temp[,final:=overall*(1/(t.score)**2)+pool*(1-1/(t.score)**2)]
    temp$t.score[is.na(temp$t.score)]=0
    temp$final[(temp$t.score)**2<1]=temp$overall[(temp$t.score)**2<1]
    temp$final[temp$is.var==0]=temp$overall[temp$is.var==0]
    temp$final[is.na(temp$final)]=0
    temp=temp[,':='(lower=overall-coef.lower*abs(overall),upper=overall+coef.upper*abs(overall))]
    temp=temp[,final1:=final]
    temp=temp[final<lower,final1:=lower]
    temp=temp[final>upper,final1:=upper]
    # sign check
    if (is.signcheck){
      temp[is.pos==1,final1:=ifelse((final1>=0),final1,0)]
      temp[is.pos==0,final1:=ifelse((final1>=0),0,final1)]
    }
    temp=temp[,c("rn","final1"),with=F]
    setnames(temp,"final1",paste("X",lm.loop$group[[i]],sep="_"))
  }
  coef=Reduce(function(...) merge(...,all.x=TRUE,by="rn"), coef.post)
  A=coef[,c(2:ncol(coef)),with=F]
  dimension=substring(colnames(A),3)
  A=as.matrix(A)
  B=matrix(A,nc=ncol(A),dimnames=list(coef$rn,dimension))
  return(list(coef=B,fit=lm.pool))
}
xinzhou1023/shrinkest documentation built on May 4, 2019, 1:07 p.m.