R/nhs_colnames.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

#' exact colnames name
#' @param ... path of tsv files or dataframe or list of nhs_read()
#' @param brief logical. whether to return brief results
#' @name nhs_colnames
#' @return
#' @export
#'
nhs_colnames <- function(...,brief=FALSE) UseMethod('nhs_colnames')

#' @rdname nhs_colnames
#' @method nhs_colnames character
#' @export
nhs_colnames.character <- function(...,brief=FALSE){
    hold <- c(...)
    ck <- grepl(get_config_path(),hold,ignore.case = TRUE)
    (files <- hold[ck])
    (variable <- tolower(hold[!ck]))
    if (length(files)==0) files <- nhs_tsv(cat = FALSE)
    files <- unique(files)
    ck <- tools::file_ext(files) != 'tsv'
    if (any(ck)){
        ext <- tools::file_ext(files[ck]) |> unique() |> sprintf(fmt = '\\.%s')
        files[ck] <- do::Replace0(files[ck],ext) |> sprintf(fmt = '%s.tsv')
    }
    (years <- prepare_years(files))
    if (length(files) >100) pb <- txtProgressBar(max = length(files),width = 25,style = 3)
    df <- lapply(1:length(files),function(i){
        if (length(files) >100) setTxtProgressBar(pb,i)
        namei <- data.table::fread(file = files[i],check.names = FALSE,showProgress = FALSE,data.table = FALSE,nrows = 1) |>
            colnames()
        if (length(variable)>0){
            ck <- lookl(namei,variable,ignore.case = TRUE)
            namei <- namei[ck]
            namei
        }
        if (length(namei)>0){
            varLabel <- do::Replace(files[i],'\\.tsv','.varLabel')
            varLabel <- read.delim(varLabel,comment.char = '#',row.names = 1)[namei,]
            filei <- do::file.name(files[i]) |> do::Replace0('\\.tsv')
            dfi <- cbind(Year=prepare_years(files[i]),Items=prepare_items(files[i]),
                         file=filei,variable=namei) |>
                as.data.frame()
            if (all(is.na(varLabel))) return(dfi)
            if (nrow(varLabel)>0) dfi <- cbind(dfi,varLabel)
            dfi
        }
    }) |>
        do.call(what = plyr::rbind.fill)
    if (is.null(df)){
        cat('result: 0')
        return()
    }
    df[is.na(df)] <- ''
    df <- df[, sapply(df, function(i) any(tryCatch(nchar(i) > 0,error=function(e) T))),drop=FALSE]
    class(df) <- c('nhs_colnames','data.frame')
    if (brief){
        brief <- df[,c('Year','Items','file','variable')] |>
            reshape2::dcast(variable~Year,value.var='variable')
        row.names(brief) <- brief$variable
        brief <- brief[,-which(colnames(brief) == 'variable'),drop=FALSE]
        if (nrow(brief)>0){
            rnms <- row.names(brief)
            for (i in 1:length(rnms)) {
                if (i %% 5 ==0 & length(rnms)>5){
                    rnms[i] <- sprintf('"%s",\n',rnms[i])
                }else{
                    rnms[i] <- sprintf('"%s",',rnms[i])
                }
                if (i==length(rnms)) clipr::write_clip(paste0(rnms,collapse = ''))
            }
        }
        return(brief)
    }
    df
}
#' @param order logical. whether to order by colnames
#' @rdname nhs_colnames
#' @method nhs_colnames list
#' @export
nhs_colnames.list <- function(...,order=FALSE,brief=FALSE){
    hold <- list(...)
    files <- hold[[1]]
    rules <- hold[-1] |> unlist() |> unique()
    years <- names(files)
    df <- lapply(files,function(i){
        namei <- colnames(i)
        matrix(namei,nrow = 1,dimnames = list(NULL,namei)) |>
            as.data.frame()
    }) |>
        do.call(what = plyr::rbind.fill) |>
        t() |>
        data.frame(check.names = FALSE,check.rows = FALSE)
    colnames(df) <- years
    if (order) df <- df[order(row.names(df)),]
    if (!is.null(rules)) df <- df[lookl(row.names(df),rules),]
    df
}


#' @rdname nhs_colnames
#' @method nhs_colnames data.frame
#' @export
nhs_colnames.data.frame <- function(...,brief=FALSE){
    hold <- list(...)
    files <- hold[[1]]
    rules <- hold[-1] |> unlist() |> unique()
    name <- colnames(files)
    if (!is.null(rules)) name <- name[lookl(name,rules)]
    name
}