R/wt_dr_day1.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

wt_dr_day1 <- function(data,wtname=NULL,cat=TRUE){
    dl <- data
    dl2 <- dl[,colnames(dl) %in% c('Year','wtdrd1','wtdr4yr')]
    if (ncol(dl2)==3) dl2$wtdrd1[is.na(dl2$wtdrd1)] <- dl2$wtdr4yr[is.na(dl2$wtdrd1)]
    years1 <- unique(dl[,'Year'])
    years2 <- dl2$Year[!is.na(dl2$wtdrd1)] |> unique() #drop some years
    if (length(years1) != length(years2)){
        if (cat) cat('\nInvalid years cycle:',paste0(set::not(years1,years2),collapse = ', '),'\n\n')
    }
    years <-prepare_years(years2)
    n <- length(years)
    drname <- sprintf('drd1_%syr',n*2)
    if (!is.null(wtname)) drname <- wtname
    paste0('dl$',drname,'<- NA') |> do::exec()
    # * 1999-2000, 2001-2002 ---------------------------------------
    ck <- c('1999-2000','2001-2002') %in% years
    if (any(ck)){
        yeari <- c('1999-2000','2001-2002')[ck]
        if (sum(ck)==1) wtdr <- 'wtdrd1'
        if (sum(ck)==2) wtdr <- 'wtdr4yr'
        for (i in yeari) {
            dl[dl$Year==i,drname] <- dl[dl$Year==i,wtdr] * sum(ck)/n
        }
        if (cat) cat(crayon::blue(paste0(yeari,collapse = ', ')),
            paste0(drname,' = ',wtdr, ' * ',sum(ck),'/',n))
        if (cat) cat('\n')
    }

    yeari <- set::not(years,c('1999-2000','2001-2002'))
    if (length(yeari)==0) return(dl) # only the two-year cycles

    # * 2003 ~ ------------------------------------------------------------
    wtdr <- 'wtdrd1'
    head = NULL
    if (sum(ck)==2) head='           '
    for (i in yeari) {
        dl[dl$Year==i,drname] <- dl[dl$Year==i,wtdr] * 1/n
        if (cat) cat(crayon::blue(paste0(head,i)),
            paste0(drname,' = ',wtdr, ' * ',1,'/',n),'\n')
    }
    dl
}