R/attach_Drug.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

#' Attach medication usage
#'
#' @param ... passed to lookl()
#' @param data data
#' @param years years
#' @param drugname name for new drug colmun name
#' @param cat logical
#' @param goal01 transform your goal drug to number, 1 is goal, 0 is others
#' @param dcn logical. whether to show drug category name
#' @param icn logical. whether to show ingredient category name
#'
#' @return drug
#' @export
#'
attach_Drug <- function(...,data,years,
                        drugname='drug',
                        dcn=TRUE,
                        icn=TRUE,
                        cat=TRUE,
                        goal01){
    if (!missing(data))  years <- unique(data$Year)
    years <- prepare_years(years)
    x <- nhs_tsv('rxq_drug',years = years,cat = FALSE)[1]
    x <- nhs_read(x,lower_cd = T,cat = FALSE)
    x <- x[,!sapply(x, is.numeric)]
    xr <- x
    x <- x[,c('rxddrgid',set::not(colnames(x),c('Year','rxddrgid')))]
    search <- c(...)
    ck <- lookl(do::paste0_columns(x,';;;;;;;;;;'),
                search,ignore.case = TRUE)
    x <- x[ck,]
    x[is.na(x)] <- ''
    x <- x[,!sapply(x, function(i) all(nchar(do::Replace0(i,' '))==0))]
    # sapply(x, function(i) lookl(i,search,ignore.case = TRUE))

    if (length(x)==0){
        if (do::cnOS()) stop(tmcn::toUTF8("\u6CA1\u6709\u627E\u5230\u76F8\u5173\u7684\u7ED3\u679C"))
        if (!do::cnOS()) stop('no relevant results')
    }
    colnames(x)[colnames(x)=='rxddrug'] <- 'drug'
    if (cat) {
        cat(crayon::red(sprintf('drug(%s)',length(unique(x$drug)))))
        alldrug <- do::equal_length(x$drug,nchar = max(nchar(x$drug))) |>
            unique() |>
            paste0(c('','\n'))
        alldrug[1] <- paste0('\n ',alldrug[1])
        alldrug[lookl(alldrug,search,ignore.case = TRUE)] <- crayon::blue(alldrug[lookl(alldrug,search,ignore.case = TRUE)])
        cat(alldrug)
        {
            cat(crayon::red('\ndrug category name'))
            cat(crayon::red('\ningredient category name\n'))
            rxddcn <- x[,-c(1:2),drop=FALSE]
            rxddcn <- lapply(rxddcn, as.character) |>
                unlist() |> do::unique_no.NA() |> do::rm_nchar(0) |>
                do::equal_length(nchar = max(do::Nchar(rxddcn))) |>
                paste0(c('','\n'))
            rxddcn[1] <- paste0(' ',rxddcn[1])
            rxddcn[lookl(rxddcn,search,ignore.case = TRUE)] <- crayon::blue(rxddcn[lookl(rxddcn,search,ignore.case = TRUE)])
            cat(rxddcn)
        }
    }

    if (missing(data)){
        key <- strsplit(paste0(search,collapse = ','),',{1,}|\\||\\=|\\~!|\\!=|~')[[1]] |>
            do::Trim() |> do::rm_nchar(0) |> unique()
        class(x) <- c('attach_Drug','data.frame')
        attr(x,'key') <- key
        return(invisible(x))
    }
    #  attach to data
    if (dcn){
        cnj <- set::and(sprintf('rxddcn%s%s',rep(1:100,each=26),rep(letters,100)),colnames(x))
        cnjc <- sapply(1:nrow(x), function(k) as.character(x[k,cnj]) |> unique() |> paste0(collapse = ';'))
        x$dcn <- cnjc
        x <- drop_col(x,cnj)
    }
    if (icn){
        cnj <- set::and(sprintf('rxdicn%s%s',rep(1:100,each=26),rep(letters,100)),colnames(x))
        cnjc <- sapply(1:nrow(x), function(k) as.character(x[k,cnj]) |> unique() |> paste0(collapse = ';'))
        x$icn <- cnjc
        x <- drop_col(x,cnj)
    }
    # divide drugs into 2 parts: search drug, other drug
    x1 <- dplyr::full_join(x,xr[,'rxddrgid',drop=FALSE],'rxddrgid')
    ck <- is.na(x1$drug)
    x1$drug[ck] <- 'other'
    if (dcn) x1$dcn[ck] <- 'other'
    if (icn) x1$icn[ck] <- 'other'

    d <- nhs_read(nhs_tsv('rxq_rx',cat = FALSE,years=years),
                   'rxddrgid',cat = FALSE)
    d <- d[nchar(d$rxddrgid)>0 & !is.na(d$rxddrgid),]
    d <- dplyr::left_join(d[,c("seqn","rxddrgid")],x1,'rxddrgid')
    d <- drop_col(d,'rxddrgid')
    d <- unique(d)

    dupseqn <- unique(set::and(d$seqn[d$drug=='other'],d$seqn[d$drug!='other']))
    d <- d[!((d$seqn %in% dupseqn) & (d$drug=='other')),]

    if (any(anyDuplicated(d$seqn))){
        seqn <- unique(d$seqn[duplicated(d$seqn)])
        for (i in seqn) {
            n <- which(d$seqn %in% i)
            goal_drug  <- paste0(do::increase(unique(unlist(strsplit(d$drug[n],';')))),collapse = ';')
            if (dcn) goal_dcn  <- paste0(do::increase(unique(unlist(strsplit(d$dcn[n],';')))),collapse = ';')
            if (icn) goal_icn  <- paste0(do::increase(unique(unlist(strsplit(d$icn[n],';')))),collapse = ';')
            d[n[1],'drug'] <- goal_drug
            if (dcn) d[n[1],'dcn'] <- goal_dcn
            if (icn) d[n[1],'icn'] <- goal_icn
            d <- d[-n[-1],]
        }
    }
    if (!missing(goal01)){
        other <- ifelse(is.numeric(goal01),0,'no')
        d$drug[!is.na(d$drug) & d$drug != 'other'] <- goal01
        d$drug[d$drug == 'other'] <- other
        d$drug <- as.numeric(d$drug)

        if (dcn){
            d$dcn[!is.na(d$dcn) & d$dcn != 'other'] <- goal01
            d$dcn[d$dcn == 'other'] <- other
            d$dcn <- as.numeric(d$dcn)
        }

        if (icn){
            d$icn[!is.na(d$icn) & d$icn != 'other'] <- goal01
            d$icn[d$icn == 'other'] <- other
            d$icn <- as.numeric(d$icn)
        }
    }
    dn <- c("seqn","drug")
    if (dcn) dn <- c(dn,'dcn')
    if (icn) dn <- c(dn,'icn')
    d <- d[,dn]
    colnames(d)[2] <- drugname
    if (dcn) colnames(d)[colnames(d)=='dcn'] <- paste0(drugname,'_dcn')
    if (icn) colnames(d)[colnames(d)=='icn'] <- paste0(drugname,'_icn')
    if (!missing(data)) data <- dplyr::left_join(data,d,'seqn')
    return(data)
}