R/highlight.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

#' high light
#'
#' @param x dataframe or vector
#' @param ... one or more key words
#' @param colors colors
#'
#' @return high light
#' @export
#'
highlight <- function(x,...,colors=NULL){
    if (is.null(colors)) colors=c("#FFFF0080", "#00FF0033", "#DEA28280",
                                  "#FF000080",
                                  "#C1C3EE80", "#C08BED80", "#7CF14180", "#E6EDDD80", "#8A5DB280",
                                  "#953BAE80", "#69EA9D80", "#888FAE80", "#4858E480", "#AAE0BE80",
                                  "#ADAA9F80", "#E2DE7E80", "#E1969D80", "#D765A380", "#67CBE680",
                                  "#5E1C9580", "#AD3DDE80", "#A565EE80", "#6FB32F80", "#BAD7E280",
                                  "#535B9980", "#E197DE80", "#E366E880", "#A89BE480", "#CDEC3480",
                                  "#DECF4280", "#E7C6D780", "#CF55B380", "#70B2E380", "#D2C79180",
                                  "#8CE46E80", "#DC562F80", "#F287EF80", "#E6EFB880", "#C8E97180",
                                  "#D8825180", "#8238EA80", "#E43B9180", "#89C27980", "#E4B3E380",
                                  "#EA456E80", "#EBC5B680", "#50A27B80", "#707BE680", "#E7AD4F80",
                                  "#5C94E680", "#E23AC580", "#56696380", "#E2706C80", "#59EBEC80"
    )
    (first <- tmcn::toUTF8("\u9B51"))
    (mid <- tmcn::toUTF8("\u9B45"))
    (last <- tmcn::toUTF8("\u9B49"))
    hl <- c(...) |> unique()
    if (length(hl)==0){
        if (!is.atomic(x)){
            if (do::cnOS()) tmcn::toUTF8("\u6CA1\u6709\u6307\u5B9A\u9AD8\u4EAE\u5BF9\u8C61,\u53EA\u80FD\u9AD8\u4EAE\u5411\u91CF") |> stop()
            if (!do::cnOS()) "No highlighted object is specified, only vectors can be highlighted" |> stop()
        }
        hl <- unique(x)
    }
    if (any(hl %in% c(first,mid,last))) stop('can not highlight',paste0(hl[hl %in% c(first,mid,last)],collapse = ', '))
    rk <- order(nchar(hl),decreasing = TRUE)
    hl <- hl[rk]
    plt <- colors[seq_len(length(hl))]
    plt <- plt[rk]
    (ck <- is.atomic(x))
    if (ck) x <- data.frame(x)
    x1 <- paste0_columns(x,'---------')
    x2 <- add_color_to_text(x1,hl,plt) |>
        do::Replace(first,'<span style="background-color:') |>
        do::Replace(mid,'">') |>
        do::Replace(last,'</span>') |>
        do::col_split('---------',colnames = colnames(x))
    # if (ck) return(x4[,1])
    x2
}

# 1:<span style="background-color:
# 2:</span>
paste0_columns <- function(df,collapse=','){
    if (ncol(df)==1){
        df[,1]
    }else{
        apply(df,1,paste0,collapse=collapse)
    }
}
add_color_to_text <- function(text,key,color){
    # text is one vector
    # key is one vector
    # color is one vector
    # length key == length color
    (first <- tmcn::toUTF8("\u9B51"))
    (mid <- tmcn::toUTF8("\u9B45"))
    (last <- tmcn::toUTF8("\u9B49"))
    names(color) <- tolower(key)
    from <- lapply(key, function(i) stringr::str_extract_all(text,
                                                             stringr::fixed(i,TRUE))) |>
        unlist() |>
        unique()
    if (length(from)==0) return(text)
    to <- sprintf('%s%s%s%s%s',
                  first,color[tolower(from)],mid,from,last)
    names(to) <- from
    to
    text
    stringr::str_replace_all(text,to)
}