Add tooltip to abbreviated data table names - r

How can you add a tool tip to column header in a data table display
output$table <- renderDataTable({
df <- iris
colnames(df) <- sapply(names(df), function(x) abbreviate(x))
df
})
The actual data frame i'm using (which I can't show) has very long names and there are >20 columns. So abbreviating is necessary to show the entire data frame with minimal horizontal scrolling. I'm looking for a way to add a hover over tool tip that shows the full, un-abbreviated name of each column when you hover over an abbreviated column header.

dat <- iris[1:3,]
names(dat) <- c(
"A long name",
"Another long name",
"Yet another long name",
"This name is long as well",
"This one is not short"
)
headerCallback <- c(
"function(thead, data, start, end, display){",
" var ncols = data[0].length;",
sprintf(" var shortnames = [%s]",
paste0(paste0("'",abbreviate(names(dat)),"'"), collapse = ",")),
sprintf(" var tooltips = [%s];",
paste0(paste0("'",names(dat),"'"), collapse = ",")),
" for(var i=0; i<ncols; i++){",
" $('th:eq('+i+')',thead).attr('title', tooltips[i]).text(shortnames[i]);",
" }",
"}"
)
datatable(dat, rownames = FALSE,
options = list(
headerCallback = JS(headerCallback)
)
)

Related

Add hyperlink to cell of flextable that open in a new tab

How do I add a hyperlink to the text in a cell of a flextable? The hyperlink should be underlined and open in a new tab.
In the R script below, This is a link to google. should be the hyperlink.
I included the hyperlink_text example from the documentation which results in an error for me.
library(tidyverse)
library(flextable)
df <- tibble(
desc = c("R1", "R2", "R3"),
A = c("This is a long sentence that should go over into B's column. This is a link to google.", "just one cell in colA", "just one cell in colA"),
B = c("", "just one cell in colB", "just one cell in colB"),
C = c("just one cell in colC", "just one cell in colC", "just one cell in colC")
)
flextable(df) |>
merge_at(i = 1, j = 2:3)
# hyperlink_text p.103
# From documentation: https://cran.r-project.org/web/packages/flextable/flextable.pdf
dat <- data.frame(
col = "Google it",
href = "https://www.google.fr/search?source=hp&q=flextable+R+package",
stringsAsFactors = FALSE)
ftab <- flextable(dat)
ftab <- compose( x = ftab, j = "col",
value = as_paragraph(
"This is a link: ",
hyperlink_text(x = col, url = href ) ) )
# Error in data.frame(x = x, url = url, stringsAsFactors = FALSE) :
# object 'href' not found

Issue with R-Script populating required content in excel

This script outputs excel spreadsheets of different region. However, since I included a column "Later", changed the corresponding template to also include the column "Later" and increased the number on this line "df <- subset(clist[,c(1:18, 20:29)" from 28 to 29 (given the increased column). The output on the column "group" has come back with its content, but with quotation mark and some instance with CHAR(10).
Is there anyway I can edit this script to have column "group" outcome its content without the quotation marks. Please help!! help! I have struggled with this since. See script below
NB changes made to the original script are as follows
inclusion of later in the sqlcode
changing the df <- subset(clist[,c(1:18, 20:28)" to df <- subset(clist[,c(1:18, 20:29)
Changing the second df <- subset(clist[,c(1:17, 19:28)] to df <- subset(clist[,c(1:18, 20:29)]
#####Constants#####
requiredpackages <- c("XLConnect", "RPostgreSQL", "svDialogs", "getPass")
reqpackages <- function(requiredpackages){
for( i in requiredpackages ){
if( ! require( i , character.only = TRUE ) ) {
install.packages( i , dependencies = TRUE )
library( i , character.only = TRUE )
}
}
}
# set the version to 1.0.5
packageurl <- "https://cran.r-project.org/src/contrib/Archive/XLConnect/XLConnect_1.0.5.tar.gz"
install.packages(packageurl, repos=NULL, type="source")
library(XLConnect)
library(RPostgreSQL)
library(svDialogs)
library(getPass)
source("N:/Ana/Code/Analysiss/Rational/R SQL working/postgresql-avd.R")
#####Retrieve data from analysis server#####
sqlcode <- paste("SELECT concat_ws(';',datacompletion,sortprovider) as datacompletion,ba,outstandingdata,provider,summary,
m,m_hos,m_sur,m_for,m_dob,ed,
bkhos,delhos,
pregnancy,b_d,
b,b_na,
group,groupsw,later,estimated,
screening,date,screening2,
booking,city,use,con,water
FROM common.etl_chasing
where ((date::text like '%",tperiod,"%' or date::text like '%",cperiod,"%')
and (anomalygroup like '%Down%' or group like '%Edwards%' or group like '%Patau%'))
or eddfyear like '%", fperiod,"%' or cleanyear like '%", cperiod, "%'", sep='')
con <- createConnection()
clist <- dbGetQuery(con, sqlcode)
dbDisconnect(con)
#####Create new folder on PID drive to output chasing lists to#####
dirname <- paste("P:/Data/Antenatal/Testing/", Sys.Date(),sep='')
dir.create(dirname)
#####Export CSV of all data#####
write.csv(clist,paste(dirname,"/masterlist.csv",sep=''))
#####Copy template for all individual providers#####
sortproviders <- unique(clist$sortprovider)
inpath <- "P:/Data/National/Antenatal/Template17b.xlsx"
for (i in seq_along(sortproviders)) {
outpath <- paste(dirname,"/",sortproviders\[i\]," AN LIST.xlsx", sep='')
file.copy(from = inpath, to = outpath)
}
#####Populate templates for individual providers#####
swpatterns <- c("68 - ", "70 - ", "72 - ", "73 - ", "84 - ", "93 - ", "94 - ", "95 - ", "96 - ", "99 - ")
#grepl(paste(swpatterns, collapse = "|"), sortproviders\[1\])
#otherpatterns \<- c("72 - ", "96 - ", "73 - ", "93 - ", "94 - ", "72 - ", "99 - ")
#swsortproviders \<- unique(grep(paste(swpatterns, collapse = "|"), sortproviders, value = TRUE))
#restsortprividers \<- unique(grep(paste(otherpatterns, collapse = "|"), sortproviders, value = TRUE))
for (i in seq_along(sortproviders)) {
outpath \<- paste(dirname,"/",sortproviders\[i\]," AN LIST.xlsx", sep='')
if (grepl(paste(swpatterns, collapse = "|"), sortproviders\[i\]) == FALSE) {
df <- subset(clist[,c(1:18, 20:29)], sortprovider == sortproviders[i])
dfformulacol <- as.vector(df$anomalygroup)
df <- cbind(df, df)
XLConnect::writeWorksheetToFile(outpath, df, sheet = "trust list", startRow = 4, header = FALSE, styleAction = XLC$"STYLE_ACTION.NONE")
wb <- loadWorkbook(filename = outpath, create = FALSE)
for (j in seq_along(dfformulacol)) {
setCellFormula(wb, "trust list", j+3, 18, dfformulacol[j])
}
for (k in seq_along(dfformulacol)) {
setCellFormula(wb, "trust list", k+3, 45, dfformulacol[k])
}
saveWorkbook(wb)
rm(wb)
} else {
df <- subset(clist[,c(1:18, 20:29)], sortprovider == sortproviders[i])
df <- cbind(df, df)
XLConnect::writeWorksheetToFile(outpath, df, sheet = "trust list", startRow = 4, header = FALSE, styleAction = XLC$"STYLE_ACTION.NONE")
wb <- loadWorkbook(filename = outpath, create = FALSE)
saveWorkbook(wb)
rm(wb)
}
rm(df)
xlcFreeMemory()
}
#####################################

How to loop through values in a data frame with the PrepText() command?

I have a data frame that stores names of saved data frame objects in my R session:
col1 <- c("what is this", "how are you", "hello im good")
df <- data.frame(col1)
The what is this object looks like this:
title <- c("this is a cat", "this is a dog", "this is a dog")
body <- c("the cat is very cute", "who cares", "here is a bone")
`what is this` <- data.frame(title, body)
I want to be able to loop through all three object names in the df data frame using the textnets package and stack the text_centrality results on top of each other. I wrote the following code:
for (row in 1:nrow(df)) {
prepped_header <- PrepText(df[row, "col1"], groupvar = "title", textvar = "body", node_type = "groups", tokenizer = "words", pos = "nouns", remove_stop_words = TRUE, compound_nouns = TRUE)
header_text_network <- CreateTextnet(prepped_header)
text_centrality <- TextCentrality(header_text_network)
}
I am getting the following error message:
Error in PrepText(df[row, "col1"], groupvar = "title", textvar = "body", :
unused arguments (groupvar = "title", textvar = "body", node_type = "groups", tokenizer = "words", pos = "nouns", remove_stop_words = TRUE, compound_nouns = TRUE)
Any guidance would be appreciated!

Sorting with NA using datatable function in DT package

I am trying to create an html table using the datatable function in the DT package so that when I sort the data in R markdown, missing rows are sorted after the highest number.
For example, in the following table, when I sort by "age" in the markdown file, I would like the row with NA to be listed last so that the order is 14,15,21,NA.
dat <- data.frame("Age" = c(21,15,NA,14),
"Name" = c("John","Dora", "Max", "Sam"),
"Gender" = c("M","F","M",NA))
DT::datatable(dat, filter = c("top"))
I have tried using "na.last = TRUE" and this works when the datatable initially prints, however when clicking the column to sort, NA is still before 14.
Any help would be much appreciated!
With the render columnwise option, you can set the value of the missing values during the sorting:
library(DT)
dat <- data.frame("Age" = c(21,15,NA,14),
"Name" = c("John","Dora", "Max", "Sam"),
"Gender" = c("M","F","M",NA))
render <- JS(
"function(data, type, row) {",
" if(type === 'sort' && data === null) {",
" return 999999;",
" }",
" return data;",
"}"
)
datatable(
dat,
filter = "top",
options = list(
columnDefs = list(
list(targets = 1, render = render)
)
)
)

Freeze panes Shiny App Rstudio

I used this link to color cells in a table: R shiny color dataframe
I've tried to change this code to allow for locking the first column in a table as the user scrolls from left to right, but haven't been able to figure it out.
Can anyone help on this?
colortable <- function(htmltab, css, style="table-condensed table-bordered"){
tmp <- str_split(htmltab, "\n")[[1]]
CSSid <- gsub("\\{.+", "", css)
CSSid <- gsub("^[\\s+]|\\s+$", "", CSSid)
CSSidPaste <- gsub("#", "", CSSid)
CSSid2 <- paste(" ", CSSid, sep = "")
ids <- paste0("<td id='", CSSidPaste, "'")
for (i in 1:length(CSSid)) {
locations <- grep(CSSid[i], tmp)
tmp[locations] <- gsub("<td", ids[i], tmp[locations])
tmp[locations] <- gsub(CSSid2[i], "", tmp[locations],
fixed = TRUE)
}
tmp[1] = "<table class=\"display responsive no-wrap\" width=\"100%\" cellspacing=\"0\" cellpadding =\"0\">"
htmltab <- paste(tmp, collapse="\n")
Encoding(htmltab) <- "UTF-8"
list(
tags$style(type="text/css", paste(css, collapse="\n")),
tags$script(sprintf(
'$( "table" ).addClass( "table %s" );', style
)),
HTML(htmltab)
)
}

Resources