R/nhs_view.R

In yikeshu0611/nhanesR: Tools for "NHANES" Database

#' View result of nsh_datafile()
#'
#' @param x result of nsh_datafile()
#' @param ... key words for high light
#' @param scroll_height scroll height, default is "600px"
#' @return data in viewer pannel in RStudio
#' @export
#'
nhs_view <- function(x,...) UseMethod('nhs_view')
#' @method nhs_view svy_tableone
#' @export
nhs_view.svy_tableone <- function(x,...){
    row.names(x) <- NULL
    if ('strata' %in% class(x)){
        if ('wtn' %in% class(x)){
            if ('total' %in% class(x)){
                ck <- grepl('\\[',x$variable)
                x[!ck,'variable'] <- paste0(do::rep_n('&nbsp;',8),x[!ck,"variable"])
                colnames(x)[colnames(x)=='variable'] <- ''
                colnames(x)[colnames(x)=="unweighted"] <- 'percent'
                colnames(x)[colnames(x)=="weighted"] <- 'Percent'
                (group_loc <- which(grepl('_unwtd_n',colnames(x))))
                (group <- colnames(x)[group_loc] |> do::Replace0('_unwtd_n'))
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_n')] <- 'n'
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_value')] <- 'prevalence'
                colnames(x)[colnames(x) %in% paste0(group,'_wtd_n')] <- 'n'
                colnames(x)[colnames(x) %in% paste0(group,'_wtd_value')] <- 'prevalence'
                h1 <- c(1,4,diff(c(group_loc,ncol(x))))
                names(h1) <- c(' ',"Study population",group,' ')[1:length(h1)]
                h2 <- c(1,2,2,rep(c(2,2),length(group)),1)
                names(h2) <- c(' ','unweighted','weighted',
                               rep(c('unweighted','weighted'),length(group)))
                x |>
                    kableExtra::kable(align = c('l',rep('c',ncol(x)-1)),escape = FALSE) |>
                    kableExtra::kable_classic(full_width=F) |>
                    kableExtra::add_header_above(h2) |>
                    kableExtra::add_header_above(h1) |>
                    kableExtra::row_spec((1:nrow(x))[ck],TRUE) |>
                    bold_change()
            }else if (!'total' %in% class(x)){
                ck <- grepl('\\[',x$variable)
                x[!ck,'variable'] <- paste0(do::rep_n('&nbsp;',8),x[!ck,"variable"])
                colnames(x)[colnames(x)=='variable'] <- ''
                (group_loc <- which(grepl('_unwtd_n',colnames(x))))
                (group <- colnames(x)[group_loc] |> do::Replace0('_unwtd_n'))
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_n')] <- 'n'
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_value')] <- 'prevalence'
                colnames(x)[colnames(x) %in% paste0(group,'_wtd_n')] <- 'n'
                colnames(x)[colnames(x) %in% paste0(group,'_wtd_value')] <- 'prevalence'
                h1 <- c(1,diff(c(group_loc,ncol(x))),1)
                names(h1) <- c(' ',group,' ')
                h2 <- c(1,rep(c(2,2),length(group)))
                names(h2) <- c(' ',rep(c('unweighted','weighted'),length(group)))
                x |>
                    kableExtra::kable(align = c('l',rep('c',ncol(x)-1)),escape = FALSE) |>
                    kableExtra::kable_classic(full_width=F) |>
                    kableExtra::add_header_above(h2) |>
                    kableExtra::add_header_above(h1) |>
                    kableExtra::row_spec((1:nrow(x))[ck],TRUE) |>
                    bold_change()
            }

        }else if(!'wtn' %in% class(x)){
            if ('total' %in% class(x)){
                ck <- grepl('\\[',x$variable)
                x[!ck,'variable'] <- paste0(do::rep_n('&nbsp;',8),x[!ck,"variable"])
                colnames(x)[colnames(x)=='variable'] <- ''
                (group_loc <- which(grepl('_unwtd_n',colnames(x))))
                (group <- colnames(x)[group_loc] |> do::Replace0('_unwtd_n'))
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_n')] <- 'n'
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_value')] <- 'unweighted'
                colnames(x)[colnames(x) %in% paste0(group,'_wtd_value')] <- 'weighted'
                h1 <- c(1,3,diff(c(group_loc,ncol(x))),1)
                names(h1) <- c(' ',"Study population",group,' ')
                x |>
                    kableExtra::kable(align = c('l',rep('c',ncol(x)-1)),escape = FALSE) |>
                    kableExtra::kable_classic(full_width=F) |>
                    kableExtra::add_header_above(h1) |>
                    # kableExtra::add_header_above(c(" " = 1, "unweighted" = 2, "weighted" = 2)) |>
                    kableExtra::row_spec((1:nrow(x))[ck],TRUE) |>
                    bold_change()
            }else if (!'total' %in% class(x)){
                ck <- grepl('\\[',x$variable)
                x[!ck,'variable'] <- paste0(do::rep_n('&nbsp;',8),x[!ck,"variable"])
                colnames(x)[colnames(x)=='variable'] <- ''
                (group_loc <- which(grepl('_unwtd_n',colnames(x))))
                (group <- colnames(x)[group_loc] |> do::Replace0('_unwtd_n'))
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_n')] <- 'n'
                colnames(x)[colnames(x) %in% paste0(group,'_unwtd_value')] <- 'unweighted'
                colnames(x)[colnames(x) %in% paste0(group,'_wtd_value')] <- 'weighted'
                h1 <- c(1,diff(c(group_loc,ncol(x))),1)
                names(h1) <- c(' ',group,' ')
                x |>
                    kableExtra::kable(align = c('l',rep('c',ncol(x)-1)),escape = FALSE) |>
                    kableExtra::kable_classic(full_width=F) |>
                    kableExtra::add_header_above(h1) |>
                    # kableExtra::add_header_above(c(" " = 1, "unweighted" = 2, "weighted" = 2)) |>
                    kableExtra::row_spec((1:nrow(x))[ck],TRUE) |>
                    bold_change()
            }

        }

    }else if(!'strata' %in% class(x)){
        ck <- grepl('\\[',x$variable)
        x[!ck,'variable'] <- paste0(do::rep_n('&nbsp;',8),x[!ck,"variable"])
        colnames(x)[colnames(x)=='variable'] <- ''
        colnames(x)[colnames(x)=="unweighted"] <- 'percent'
        colnames(x)[colnames(x)=="weighted"] <- 'Percent'
        x |>
            kableExtra::kable(align = c('l','c','c','c','c'),escape = FALSE) |>
            kableExtra::kable_classic(full_width=F) |>
            kableExtra::add_header_above(c(" " = 1, "unweighted" = 2,
                                           "weighted" = ifelse('wtn'%in% class(x),2,1))) |>
            kableExtra::row_spec((1:nrow(x))[ck],TRUE) |>
            bold_change()
    }

}
bold_change <- \(r){
    rs <- as.character(r) |> strsplit('<tr>') |> do::list1()
    rs[grepl('font-weight: bold;',rs)] <- sapply(rs[grepl('font-weight: bold;',rs)],function(i){
        j <- 1
        while (grepl('font-weight: bold;',i)) {
            if (j==1){
                i <- sub('font-weight: bold;','font-weight: bbbb;',i)
            }else{
                i <- sub('font-weight: bold;','',i)
            }
            j <- j+1
        }
        sub('font-weight: bbbb;','font-weight: bold;',i)
    })
    r <- paste0(rs,collapse = '<tr>')
    class(r) <- c("kableExtra",  "knitr_kable")
    r
}
#' @method nhs_view nhs_file_web
#' @export
nhs_view.nhs_file_web <- function(x,...,scroll_height="600px"){
    h0 <- c(...)
    x <- cbind(seq=1:nrow(x),x)
    if (!is.null(h0)){
        ck <- !colnames(x) %in% c("DOC  url","Data url")
        x[,ck] <- highlight(x[,ck],h0)
    }
    kableExtra::kbl(x[,1:7],
                    escape = FALSE,
                    align=c('c','c','l','l','l','l','l')) |>
        kableExtra::kable_paper("striped") |>
        kableExtra::column_spec(5,link = x$`DOC  url`) |>
        kableExtra::column_spec(6,link = x$`Data url`) |>
        kableExtra::row_spec(0,align = 'c') |>
        kableExtra::scroll_box(height = scroll_height)

}

#' @method nhs_view nhs_search
#' @export
#'
nhs_view.nhs_search <- function(x,...,label=TRUE,description=TRUE,target=TRUE,
                                instructions=TRUE,hard.edits=TRUE,
                                datafame=FALSE,scroll_height="600px"){
    (h0 <- c(...) |> unique())
    (h1 <- attr(x,"nhs_search"))
    hl <- unique(c(h1,h0))
    x[,-which(colnames(x) == 'url')] <- highlight(x[,-which(colnames(x) == 'url')],hl)
    colnames(x)[colnames(x)=='item'] <- 'Items'
    colnames(x)[colnames(x)=='year'] <- 'Year'
    class(x) <- c('nhs_colnames','data.frame')
    nhs_view(x,label=label,description=description,target=target,instructions=instructions,
             hard.edits=hard.edits,datafame=datafame,scroll_height=scroll_height)
}
#' @method nhs_view nhs_colnames
#' @rdname nhs_view
#'
#' @param label logical. whether to show label column
#' @param description logical. whether to show description column
#' @param target logical. whether to show target column
#' @param instructions logical. whether to show instructions column
#' @param hard.edits logical. whether to show hard.edits column
#' @param datafame logical. whether to return dataframe
#' @export
#'
nhs_view.nhs_colnames <- function(x,...,label=TRUE,description=TRUE,target=TRUE,
                                  instructions=TRUE,hard.edits=TRUE, datafame=FALSE,
                                  combine=NULL,scroll_height="600px"){
    df <- x
    variable <- c(...)
    if (!is.null(variable)){
        df <- df[lookl(df$variable,...,ignore.case = TRUE),]
    }
    if (!is.null(combine)){
        for (i in combine) {
            ii <- strsplit(i,' {0,}[,;] {0,}')[[1]] |> unique()
            ii <- ii[ii %in% df$'variable']
            df[df$'variable' %in% ii,'variable'] <- paste0(ii,collapse = ',')
        }
    }
    x <- reshape2::dcast(df,Items+variable~Year,toString,value.var = 'file')
    colnames(x) <- do::Replace(colnames(x),'-','<br>')
    id <- paste0_columns(df[,c('Items','variable')],'---------')
    id_dup <- unique(id[duplicated(id)])
    for (i in id_dup) {
        (ck <- which(id==i))
        if ('label' %in% colnames(df) & label){
            (lab <- df[ck,'label'])
            (cklab <- duplicated(tolower(lab)))
            (labi <- lab[!cklab])
            if (length(labi)>1){
                labi <- sapply(labi, function(j){
                    (ckj <- tolower(lab) == tolower(j))
                    hf <- unique(df[ck,'file'][ckj]) |> paste0(collapse = ',') |> highlight(colors = '#37d8bf')
                    paste0(hf,'<br>',j)
                }) |> paste0(collapse = '<br>')
            }
            df[ck[1],'label'] <- labi
        }
        if ('description' %in% colnames(df) & description){
            (lab <- df[ck,'description'])
            (cklab <- duplicated(tolower(lab)))
            (labi <- lab[!cklab])
            if (length(labi)>1){
                labi <- sapply(labi, function(j){
                    (ckj <- tolower(lab) == tolower(j))
                    hf <- unique(df[ck,'file'][ckj]) |> paste0(collapse = ',') |> highlight(colors = '#37d8bf')
                    paste0(hf,'<br>',j)
                }) |> paste0(collapse = '<br>')
            }
            df[ck[1],'description'] <- labi
        }
        if ('target' %in% colnames(df) & target){
            (lab <- df[ck,'target'])
            (cklab <- duplicated(tolower(lab)))
            (labi <- lab[!cklab])
            if (length(labi)>1){
                labi <- sapply(labi, function(j){
                    (ckj <- tolower(lab) == tolower(j))
                    hf <- unique(df[ck,'file'][ckj]) |> paste0(collapse = ',') |> highlight(colors = '#37d8bf')
                    paste0(hf,'<br>',j)
                }) |> paste0(collapse = '<br>')
            }
            df[ck[1],'target'] <- labi
        }
        if (('instructions' %in% colnames(df)) & instructions){
            (lab <- df[ck,'instructions'])
            (cklab <- duplicated(tolower(lab)))
            (labi <- lab[!cklab])
            if (length(labi)>1){
                labi <- sapply(labi, function(j){
                    (ckj <- tolower(lab) == tolower(j))
                    hf <- unique(df[ck,'file'][ckj]) |> paste0(collapse = ',') |> highlight(colors = '#37d8bf')
                    paste0(hf,'<br>',j)
                }) |> paste0(collapse = '<br>')
            }
            df[ck[1],'instructions'] <- labi
        }
        if (('hard.edits' %in% colnames(df)) & hard.edits){
            (lab <- df[ck,'hard.edits'])
            (cklab <- duplicated(tolower(lab)))
            (labi <- lab[!cklab])
            if (length(labi)>1){
                labi <- sapply(labi, function(j){
                    (ckj <- tolower(lab) == tolower(j))
                    hf <- unique(df[ck,'file'][ckj]) |> paste0(collapse = ',') |> highlight(colors = '#37d8bf')
                    paste0(hf,'<br>',j)
                }) |> paste0(collapse = '<br>')
            }
            df[ck[1],'hard.edits'] <- labi
        }
    }
    df2 <- df[!duplicated(id),set::not(colnames(df),c('Year','Years','file'))]
    if ((('instructions' %in% colnames(df)) & !instructions)) df2 <- df2[,set::not(colnames(df2),'instructions')]
    if ((('description' %in% colnames(df)) & !description)) df2 <- df2[,set::not(colnames(df2),'description')]
    if ((('label' %in% colnames(df)) & !label)) df2 <- df2[,set::not(colnames(df2),'label')]
    if ((('target' %in% colnames(df)) & !target)) df2 <- df2[,set::not(colnames(df2),'target')]
    if ((('hard.edits' %in% colnames(df)) & !hard.edits)) df2 <- df2[,set::not(colnames(df2),'hard.edits')]
    r <- dplyr::full_join(x,df2, by = c("Items", "variable"))
    if(datafame){
        colnames(r) <- do::Replace(colnames(r),'<br>','-')
        for (i in 1:ncol(r)) {
            r[,i] <- do::Replace0(r[,i],'<span style="background-color:#37d8bf">','</span>')
            r[,i] <- do::Replace(r[,i],'<br>','/')
        }
        return(r)
    }
    df2 <- unique(df[,c('file','url')])
    url <- df2$url
    names(url) <- df2$file
    url <- do::rm_nchar(url,5)
    ck <- grepl('[0-9]{4}<br>[0-9]{4}',colnames(r))
    obj <- colnames(r)[ck]
    for (i in obj) {
        ri <- r[,i]
        if (length(ri)==0) next(i)
        for (j in 1:length(ri)) {
            if (nchar(ri[j])<1) next(j)
            js <- strsplit(r[j,i],' {0,}, {0,}')[[1]]
            anchor <- toupper(r[j,'variable']) |>
                do::Replace0('<SPAN STYLE=\\"BACKGROUND-COLOR:#.{,15}\\">','</SPAN>')
            r[j,i] <- paste0(html_URL(js,url[js],anchor),collapse = ', ')
        }
    }
    r1 <- r[,set::not(colnames(r),'url')]
    if (nrow(r1)==1){
        r2 <- cbind(' '='1:End',r1)
    }else{
        r2 <- cbind(' '=c(1:(nrow(r1)-1),paste0(nrow(r1),':End')),r1)
    }
    kableExtra::kbl(r2,
                    escape = FALSE,
                    align=c('c','l','l',rep('c',sum(ck)),rep('l',10))) |>
        kableExtra::kable_styling(full_width = TRUE) |>
        kableExtra::row_spec(0,align = 'c') |>
        kableExtra::scroll_box(height = scroll_height)
}
#' @export
#' @method nhs_view target
nhs_view.target <- function(x,...){
    anchor <- if('anchor' %in% colnames(x)) x$anchor else x$variable
    x$variable <- html_URL(x = x$variable,href = x$url,name = toupper(anchor))
    x <- x[,c("target","year","item","file","variable")]
    id <- paste0_columns(x[,c("year","item","file")])
    idu <- unique(id)
    for (i in 1:length(idu)) {
        if (i==1) r <- NULL
        ck <- id == idu[i]
        tck <- x[ck,]
        tu <- unique(tck$target)
        for (j in tu) {
            (ckj <- which(tck$target==j))
            pck <- tck[ckj,"variable"]
            kmax <- 5
            if (length(pck)>kmax){
                pck <- sapply(1:round(length(pck)/kmax), function(k){
                    if (k < round(length(pck)/kmax)){
                        paste0(pck[(k*kmax-(kmax-1)):(k*kmax)],collapse = ',')
                    }else{
                        paste0(pck[(k*kmax-(kmax-1)):length(pck)],collapse = ',')
                    }
                }) |> paste0(collapse = '<br/>')

            }else{
                pck <- paste0(pck,collapse = ',')
            }
            tck[ckj[1],"variable"] <- pck
            if (length(ckj)>1 ) tck <- tck[-ckj[-1],]
        }
        r <- rbind(r,tck)
    }
    r <- r[order(r$target,decreasing = TRUE),]
    row.names(r) <- 1:nrow(r)
    kableExtra::kbl(r,row.names = TRUE,
                    escape = FALSE,
                    align=c('l','c','c','c','l')) |>
        kableExtra::kable_styling(full_width = TRUE) |>
        kableExtra::row_spec(0,align = 'c') |>
        kableExtra::scroll_box(height = '600px')
}




#' @export
#' @method nhs_view attach_Drug
nhs_view.attach_Drug <- function(x,...){
    key <- attr(x,'key')
    x <- highlight(x,key)
    x[is.na(x)] <- ''
    for (i in 1:ncol(x)) {
        if (grepl('rxddcn',colnames(x)[i])){
            colnames(x)[i] <- highlight(colnames(x)[i],colors = 'yellow')
        }
    }
    kableExtra::kbl(x,row.names = TRUE,
                    escape = FALSE,
                    align=c('l','c','c','c','l')) |>
        kableExtra::kable_styling(full_width = FALSE) |>
        kableExtra::row_spec(0,align = 'c') |>
        kableExtra::scroll_box(height = '600px')
}