R/recode.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

#' Recode numeric and character
#'
#' @param x one numeric or character vector
#' @param ... pattern for replacement
#' @param string logical. whether convert number to string for numeric vector.
#' @param cat logical. whether to print message
#' @return re-coded vector
#' @export
#'
recode <- function(x,...,string=TRUE,cat=TRUE){
    replace <- c(...)
    # replace <- replace1
    if (is.data.frame(x)){
        xh <- substitute(x) |> deparse() |> paste0(collapse = '')
        for (i in 1:ncol(x)) {
            if (i==1) cmd <- c()
            if (tolower(colnames(x)[i]) %in% c('seqn','year','sdmvpsu','sdmvstra')) next(i)
            if (is.numeric(x[,i])){
                cmdi <- paste0(xh,'$',colnames(x)[i],' <- recode(',xh,'$',colnames(x)[i],',)')
            }else{
                cmdi <- eval(parse(text=paste0('recode(',xh,'$',colnames(x)[i],',cat=FALSE)')))
            }
            cmd <- c(cmd,cmdi)
            if (i==ncol(x)) clipr::write_clip(cmd)
        }
    }else if (is.character(x) | is.factor(x)){
        if (is.null(replace)){
            xh <- substitute(x) |> deparse() |> paste0(collapse = '')
            level <- levels(x)
            if (is.null(level)) level <- do::unique_no.NA(as.character(x))
            replace <- level |>
                paste0('::') |>
                paste0(collapse = '", \n"') |>
                sprintf(fmt = '"%s")')
            cmd <- paste0(xh,' <- recode','(',xh,',\n',replace)
            clipr::write_clip(cmd)
            if (do::cnOS()) if (cat) cat(crayon::red(tmcn::toUTF8("\u4F7F\u7528Ctrl+V\u9ECF\u8D34recode()\u547D\u4EE4")))
            if (!do::cnOS()) if (cat)  cat(crayon::red('Use Ctrl+V to paste the recode() command'))
            invisible(cmd)
        }else{
            (factorck <- is.factor(x))
            if (!factorck) x <- as.character(x)
            (from <- do::Replace0(replace,' {0,}:: {0,}.*'))
            (ck <- lapply(from, function(i) x == i & !is.na(x)))
            for (i in 1:length(ck)) {
                (to <- do::Replace0(replace[i],'.*:: {0,}'))
                if (to=='') next(i)
                if (to == 'NA') to <- NA
                if (factorck){
                    levels(x)[levels(x)==from[i]] <- to
                }else{
                    x[ck[[i]]] <- to
                }
            }
            return(x)
        }
    }else if (is.numeric(x)){
        if (is.null(replace)) replace <- median(x)
        if (all(is.numeric(replace))){
            if (length(replace)==1){
                ck <- x < replace
                if (string){
                    x[!is.na(ck) & ck] <- sprintf('[,%s)',replace)
                    x[!is.na(ck) & !ck] <- sprintf('[%s,]',replace)
                    level <- c(sprintf('[,%s)',replace),sprintf('[%s,]',replace))
                }else{
                    x[!is.na(ck) & ck] <- 1
                    x[!is.na(ck) & !ck] <- 2
                    cat(' < ',replace,'--->1\n')
                    cat(' >=',replace,'--->2\n\n')
                }
            }else{
                maxchr <- max(nchar(replace))
                replace <- replace[order(replace)]
                (replace <- replace[replace>min(x) & replace < max(x)])
                x0 <- x
                for (i in 1:length(replace)) {
                    if (i==1){
                        ck <- x0 < replace[1]
                        if (string){
                            x[!is.na(ck) & ck] <- sprintf('[,%s)',replace[1])
                            level <- sprintf('[,%s)',replace[1])
                        }else{
                            x[!is.na(ck) & ck] <- 1
                            if (cat) cat(paste0(paste0(do::rep_n(each = maxchr+3,' '),' < '),
                                       paste0(replace[i],do::rep_n(' ',maxchr-nchar(replace[i]))),
                                       '--->',i,'\n'))
                        }
                    }else{
                        ck <- x0 < replace[i] & x0 >= replace[i-1]
                        if (string){
                            x[!is.na(ck) & ck] <- sprintf('[%s,%s)',replace[i-1],replace[i])
                            level <- c(level,sprintf('[%s,%s)',replace[i-1],replace[i]))
                        }else{
                            x[!is.na(ck) & ck] <- i
                            if (cat) cat(paste0(
                                '>=',
                                paste0(replace[i-1],do::rep_n(' ',maxchr-nchar(replace[i-1]))),
                                '& < ',
                                paste0(replace[i],do::rep_n(' ',maxchr-nchar(replace[i]))),
                                '--->',i,'\n'))
                        }
                    }
                    if (i==length(replace)){
                        ck <- x0 >= replace[i]
                        if (string){
                            x[!is.na(ck) & ck] <- sprintf('[%s,]',replace[i])
                            level <- c(level,sprintf('[%s,]',replace[i]))
                        }else{
                            x[!is.na(ck) & ck] <- i+1
                            if (cat) cat(paste0(paste0(do::rep_n(each = maxchr+3,' '),' >='),
                                       paste0(replace[i],do::rep_n(' ',maxchr-nchar(replace[i]))),
                                       '--->',i+1,'\n\n'))
                        }

                    }
                }
                x <- factor(x,levels = level)
            }
        }else{
            x <- as.character(x)
            x <- recode(x,replace,cat=cat)
        }
        return(x)
    }
}