R/attach_GNRI.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

#' Geriatric Nutritional Risk Index, GNRI
#'
#' @param data data
#' @param years years
#' @param cut one or more numeric
#' @param method methods for caculate idael body weight. 22(default), or 105 or wlo
#' - 22: 22 * (height(m) - 0.1(female))^2
#' - 105: height(cm) - 105
#' - wlo: height(cm) - 100 - (height(cm) - 150) / (4(male), 2.5(female))
#'
#' @details GNRI consists of two parts, GNRI_1 is calculated from albumin level, and
#'     GNRI_2 is calculated from body weight. When grouping according to the cut
#'     value, first judge according to the total score of GNRI. If a subject has
#'     only one of GNRI_1 and GNRI_2, then if he has reached the highest level of
#'     grouping requirements, he will also be grouped. Otherwise, it will not be
#'     grouped.
#' - GNRI = (1.489 * Alb(g/L)) + (41.7 * (weight(kg)/IBW(kg)))
#' @references Olivier B ,  Gilles M ,  Claire D , et al. Geriatric Nutritional Risk Index: a new index for evaluating at-risk elderly medical patients[J]. American Journal of Clinical Nutrition(4):777.
#' @return GNRI
#' @export
#'
attach_GNRI <- function(data,years,cut,method=c('22','105','wlo')){

    method <- as.character(method)
    method <- match.arg(method)
    years <- data_years(data,years)
    (demo <- nhs_tsv('demo',items = 'demo',years=years,cat=FALSE))
    (bm <- nhs_tsv('bmx',items = 'exam',years=years,cat=FALSE))
    (biopro <- nhs_tsv('lab18\\.|l40_b\\.|l40_c\\.|biopro',items = 'lab',years=years,cat=FALSE))
    data0 <- nhs_read(
        demo,"riagendr:sex",
        bm,'bmxwt:weight','bmxht:height',
        biopro,'lbxsal:alb',
        lower_cd = TRUE,cat = FALSE)
    if (!missing(data)) data0 <- data0[data0$seqn %in% seqn,]
    IBW <- rep(NA,length(data0$sex))
    if (method=='105'){
        IBW <- data0$height-105
    }else if (method=='22'){
        ck <- data0$sex=='male'
        IBW[ck] <- ((data0$height[ck]/100)^2)*22
        IBW[!ck] <- ((data0$height[!ck]/100-0.1)^2)*22
    }else if (method=='wlo'){
        ck <- data0$sex=='male'
        IBW[ck] <- data0$height[ck] - 100 - (data0$height[ck]-150)/4
        IBW[!ck] <- data0$height[!ck] - 100 - (data0$height[!ck]-150)/2.5
    }

    data0$GNRI_1 <-  1.489*data0$alb*10
    data0$GNRI_2 <- 41.7*data0$weight/IBW
    data0$GNRI <- rowSums(data0[,c('GNRI_1','GNRI_2')],na.rm = FALSE)

    data0 <- data0[,c("Year", "seqn",'GNRI_1','GNRI_2',"GNRI")]

    if (!missing(cut)){
        (cut <- do::increase(cut))
        min <- min(data0$GNRI,na.rm = TRUE)
        max <- max(data0$GNRI,na.rm = TRUE)
        if (any(min(cut) < min, max(cut) > max)){
            if (do::cnOS()) stop(paste0(tmcn::toUTF8("cut\u5FC5\u987B\u5728"),floor(min),'~',ceiling(max),tmcn::toUTF8('\u4E4B\u95F4')))
            if (!do::cnOS()) stop(paste0('cut must between ',floor(min),' ~ ',ceiling(max)))
        }
        for (i in 1:length(cut)){
            if (i==1){
                cuti <- list(c(floor(min(data0$GNRI,na.rm = TRUE)),cut[i]))
            }else{
                cuti <- c(cuti,list(c(cut[i-1],cut[i])))
            }
            if (i==length(cut)) cuti <- c(cuti,list(c(cut[i],ceiling(max(data0$GNRI,na.rm = TRUE)))))
        }
        cuti
        data0$GNRI_class <- NA
        group <- c()
        for (i in 1:length(cuti)) {
            if (i<length(cuti)){
                ck3 <- data0$GNRI >= cuti[[i]][1] & data0$GNRI < cuti[[i]][2]
                group <- c(group,sprintf('[%s,%s)',cuti[[i]][1],cuti[[i]][2]))
                data0$GNRI_class[ck3] <- sprintf('[%s,%s)',cuti[[i]][1],cuti[[i]][2])
            }else if (i==length(cuti)){
                ck1 <- data0$GNRI_1 >= cuti[[i]][1]
                ck2 <- data0$GNRI_2 >= cuti[[i]][1]
                ck3 <- data0$GNRI >= cuti[[i]][1]
                group <- c(group,sprintf('[%s,%s]',cuti[[i]][1],cuti[[i]][2]))
                data0$GNRI_class[ck1 | ck2 | ck3] <- sprintf('[%s,%s]',cuti[[i]][1],cuti[[i]][2])
            }
        }
        data0$GNRI_class <- factor(data0$GNRI_class,group)
    }
    if (missing(data)){
        data <- data0
    }else{
        data0 <- data0[,!colnames(data0) %in% 'Year']
        data <- dplyr::left_join(data,data0,'seqn')
    }
    return(data)
}