R/ADRGGrouper.R

In sontron/ZJDRG: ZJDRG deal the data grouping using ZJ-DRG rules

#' ADRGGrouper
#' 
#' @export

ADRGGrouper<-function(data,adrgRulesLst=ADRGRulesLst,adrgVarsLst=ADRGVarsLst){
  
  require('data.table')
  require('stringi')
  
  ifelse(data$sex==1,'male',ifelse(data$sex==2,'female','other'))->data$sexGroup
  ifelse(data$age<=28/365,'0-28d',ifelse(data$age<=1,'28d-1y','1y-Inf'))->data$ageGroup
  
  data$bornWtGroup<-ifelse(data$bornWt<1500,'0-1500',ifelse(data$bornWt<2500,'1500-2500','2500-Inf'))
  
  # data$LOSGroup<-ifelse(data$LOS<5,'0-5','5-Inf')
  ### change location
  
  dxCodes<-adrgVarsLst$PDX
  procCodes<-adrgVarsLst$PPROC
  
  data[is.na(data)]<-'NtAvb'
  
  paste('PROC',2:8,sep='')->APROCData
  
  apply(data[,c('PROC1',APROCData)],1,function(x){
    paste(c(x[x!='NtAvb'],unique(x[x=='NtAvb'])),collapse=';')
  })->data$PROCs
  
  ifelse(data$PDX%in%dxCodes,data$PDX,'OutOfRange')->data$PDX
  ifelse(data$PROC1%in%procCodes,data$PROC1,'OutOfRange')->data$PROC1
  
  adrgRulesLst[["ADRGRulesDf"]]->ADRGRulesDf
  
  
  names(data)->namesData
  
  
  
  
  ### newly added  codes for matrix manipulation
  
  adrgRulesLst$ageRuleMat[data$ageGroup,]&adrgRulesLst$bornWtRuleMat[data$bornWtGroup,]&
    adrgRulesLst$sexRuleMat[data$sexGroup,]&adrgRulesLst$PDXRuleMat[data$PDX,]->resMat
  
  
  if(is.vector(adrgRulesLst$PDXRuleMat[data$PDX,])){
    !any(adrgRulesLst$PDXRuleMat[data$PDX,],na.rm=T)->pdxErrInd
    !any(adrgRulesLst$PPROCRuleMat[data$PROC1,],na.rm=T)->pprocErrInd
  } else {
    !apply(adrgRulesLst$PDXRuleMat[data$PDX,],1,any,na.rm=T)->pdxErrInd
    !apply(adrgRulesLst$PPROCRuleMat[data$PROC1,],1,any,na.rm=T)->pprocErrInd
  }
  
  ifelse(pdxErrInd&pprocErrInd,'PDXPPROCErr',ifelse(pdxErrInd,'PDXErr',ifelse(pprocErrInd,'PPROCErr','NoErr')))->data$Err
  
  
  if(is.vector(resMat)) {
    data$joinRule<-paste(which(resMat),collapse='|')
  } else {
    apply(resMat,1,function(x)paste(which(x),collapse='|'))->data$joinRule
  }
  
  data$joinRule[data$joinRule=='']<-'NA'
  
  as.data.table(data)->data

  IND<-NA
  
  
  unique(data[,c('PROCs','joinRule'),with=F])->data2
  
  
  apply(data2,1,function(x){
    if(x['joinRule']=='NA') NA else {
      as.numeric(unlist(strsplit(x['joinRule'],'|',fixed=T)))->ind
      lapply(ind,function(j){
        multiIncl2(x['PROCs'],ADRGRulesDf[j,"PROC"])
      })->res
      
      ind[which(unlist(res))]->indd
      indd[1]
    }
    
  })->IND
  
  
  
  data2$indRule<-IND
  
  merge(data,data2,by=c('PROCs','joinRule'),all.x=T)->data
  
  if(all(is.na(data$indRule))) {
    ADRGRulesDf[data$indRule,c("MDCCode","ADRGCode","ADRGName")]->ADRGRes
    ADRGRes[1:nrow(data),]->ADRGRes
  } else {
    ADRGRulesDf[data$indRule,c("MDCCode","ADRGCode","ADRGName")]->ADRGRes
  }
  data.frame(data,ADRGRes,stringsAsFactors = F)->dataADRGRes
  ifelse(!is.na(dataADRGRes$ADRGCode),'NoErr',ifelse(is.na(dataADRGRes$ADRGCode)&dataADRGRes$Err=='NoErr','joinErr',dataADRGRes$Err))->dataADRGRes$Err
  return(as.data.table(dataADRGRes[,c(namesData,"Err",names(ADRGRes))]))
}


#' ADRGGrouper2
#' 
#' revise MDCZ
#' 
#' @export

ADRGGrouper2<-function(data,adrgRulesLst=ADRGRulesLst3,adrgVarsLst=ADRGVarsLst){
  
  require('data.table')
  require('stringi')
  
  ifelse(data$sex==1,'male',ifelse(data$sex==2,'female','other'))->data$sexGroup
  ifelse(data$age<=28/365,'0-28d',ifelse(data$age<=1,'28d-1y','1y-Inf'))->data$ageGroup
  
  data$bornWtGroup<-ifelse(data$bornWt<1500,'0-1500',ifelse(data$bornWt<2500,'1500-2500','2500-Inf'))
  
  # data$LOSGroup<-ifelse(data$LOS<5,'0-5','5-Inf')
  ### change location
  
  dxCodes<-adrgVarsLst$PDX
  procCodes<-adrgVarsLst$PPROC
  
  data[is.na(data)]<-'NtAvb'
  
  # paste("ADX",1:15,sep='')->ADXData
  paste('PROC',2:8,sep='')->APROCData
  
  # apply(data[,ADXData],1,function(x){
  #   paste(c(x[x!='NtAvb'],unique(x[x=='NtAvb'])),collapse=';')
  # })->data$ADXs
  # 
  # apply(data[,c('PDX',ADXData)],1,function(x){
  #   paste(c(x[x!='NtAvb'],unique(x[x=='NtAvb'])),collapse=';')
  # })->data$DXs
  # 
  # apply(data[,APROCData],1,function(x){
  #   paste(c(x[x!='NtAvb'],unique(x[x=='NtAvb'])),collapse=';')
  # })->data$APROCs
  # 
  apply(data[,c('PROC1',APROCData)],1,function(x){
    paste(c(x[x!='NtAvb'],unique(x[x=='NtAvb'])),collapse=';')
  })->data$PROCs
  
  apply(data[,c('PDX',paste0('ADX',1:15))],1,function(x){
    paste(c(x[x!='NtAvb'],unique(x[x=='NtAvb'])),collapse=';')
  })->data$DXs
  
  ifelse(data$PDX%in%dxCodes,data$PDX,'OutOfRange')->data$PDX
  ifelse(data$PROC1%in%procCodes,data$PROC1,'OutOfRange')->data$PROC1
  
  adrgRulesLst[["ADRGRulesDf"]]->ADRGRulesDf
  # weightMt<-matrix(nc=length(weight),nr=nrow(ADRGRulesDf))
  # for(i in 1:ncol(weightMt)){
  #   weightMt[,i]<-weight[i]
  # }
  
  names(data)->namesData
  
  # ifelse(ADRGRulesDf$age=='[NULL]',0,weightMt[,1])->weightMt[,1]
  # 
  # ifelse(ADRGRulesDf$bornWt=='[NULL]',0,weightMt[,2])->weightMt[,2]
  # ifelse(ADRGRulesDf$sex=='[NULL]',0,weightMt[,3])->weightMt[,3]
  # ifelse(ADRGRulesDf$statusOut=='[NULL]',0,weightMt[,4])->weightMt[,4]
  # ifelse(ADRGRulesDf$LOS=='[NULL]',0,weightMt[,5])->weightMt[,5]
  # ifelse(ADRGRulesDf$PDX=='[NULL]',0,weightMt[,6])->weightMt[,6]
  # ifelse(ADRGRulesDf$PPROC=='[NULL]',0,weightMt[,7])->weightMt[,7]
  # ifelse(ADRGRulesDf$ADX=='[NULL]',0,weightMt[,8])->weightMt[,8]
  # ifelse(ADRGRulesDf$APROC=='[NULL]',0,weightMt[,9])->weightMt[,9]
  # 
  
  
  
  ### newly added  codes for matrix manipulation
  
  # adrgRulesLst$ageRuleMat[data$ageGroup,]&adrgRulesLst$bornWtRuleMat[data$bornWtGroup,]&
  #   adrgRulesLst$sexRuleMat[data$sexGroup,]&adrgRulesLst$PDXRuleMat[data$PDX,]&adrgRulesLst$PPROCRuleMat[data$PROC1,]->resMat
  adrgRulesLst$ageRuleMat[data$ageGroup,]&adrgRulesLst$bornWtRuleMat[data$bornWtGroup,]&
    adrgRulesLst$sexRuleMat[data$sexGroup,]&adrgRulesLst$PDXRuleMat[data$PDX,]->resMat
  
  
  if(is.vector(adrgRulesLst$PDXRuleMat[data$PDX,])){
    !any(adrgRulesLst$PDXRuleMat[data$PDX,],na.rm=T)->pdxErrInd
    !any(adrgRulesLst$PPROCRuleMat[data$PROC1,],na.rm=T)->pprocErrInd
  } else {
    !apply(adrgRulesLst$PDXRuleMat[data$PDX,],1,any,na.rm=T)->pdxErrInd
    !apply(adrgRulesLst$PPROCRuleMat[data$PROC1,],1,any,na.rm=T)->pprocErrInd
  }
  
  ifelse(pdxErrInd&pprocErrInd,'PDXPPROCErr',ifelse(pdxErrInd,'PDXErr',ifelse(pprocErrInd,'PPROCErr','NoErr')))->data$Err
  
  
  if(is.vector(resMat)) {
    data$joinRule<-paste(which(resMat),collapse='|')
  } else {
    apply(resMat,1,function(x)paste(which(x),collapse='|'))->data$joinRule
  }
  
  data$joinRule[data$joinRule=='']<-'NA'
  
  as.data.table(data)->data
  #data[is.na(data)]<-'NA'
  IND<-NA
  
  
  
  # which(ADRGRulesDf$ADX!='[NULL]')->indADX
  # which(ADRGRulesDf$APROC!='[NULL]')->indAPROC
  # unique(c(indADX,indAPROC))->indNULL
  
  unique(data[,c('PROCs','DXs','joinRule'),with=F])->data2
  
  
  apply(data2,1,function(x){
    if(x['joinRule']=='NA') NA else {
      as.numeric(unlist(strsplit(x['joinRule'],'|',fixed=T)))->ind
      lapply(ind,function(j){
        multiIncl2(x['PROCs'],ADRGRulesDf[j,"PROC"])&multiIncl(x['DXs'],ADRGRulesDf[j,'DX'])
      })->res
      
      ind[which(unlist(res))]->indd
      # if(length(indd)==1){
      #   sum(weightMt[indd,],na.rm=T)->sumWeight
      # } else {
      #   apply(weightMt[indd,],1,sum,na.rm=T)->sumWeight
      # }
      indd[1]
    }
    
  })->IND
  
  
  
  data2$indRule<-IND
  
  merge(data,data2,by=c('PROCs','DXs','joinRule'),all.x=T)->data
  
  if(all(is.na(data$indRule))) {
    ADRGRulesDf[data$indRule,c("MDCCode","ADRGCode","ADRGName")]->ADRGRes
    ADRGRes[1:nrow(data),]->ADRGRes
  } else {
    ADRGRulesDf[data$indRule,c("MDCCode","ADRGCode","ADRGName")]->ADRGRes
  }
  data.frame(data,ADRGRes,stringsAsFactors = F)->dataADRGRes
  ifelse(!is.na(dataADRGRes$ADRGCode),'NoErr',ifelse(is.na(dataADRGRes$ADRGCode)&dataADRGRes$Err=='NoErr','joinErr',dataADRGRes$Err))->dataADRGRes$Err
  return(as.data.table(dataADRGRes[,c(namesData,"Err",names(ADRGRes))]))
}