We Keep Coding

How to change alignment of row header column of table rendered using R package rhandsontable?

In the below minimal code examples (first one without Shiny, second one with Shiny), I'm trying to figure out how to change the alignment of the contents of the row header column in this table rendered using R package rhandsontable. The row header column contents are currently centered, I'm trying to see how you can change the aligment to left and right. I tried adding %>% hot_col(0, halign='htLeft') but this only works for non-header columns (it doesn't accept the value I tried of 0 for accessing the row header column).
Any suggestions for how to do this? I assume this takes some CSS or js.
Code version without Shiny:
library(rhandsontable)
DF = data.frame(
integer = 1:5,
numeric = rnorm(5),
factor_allow = factor(letters[1:5],
levels = letters[5:1],
ordered = TRUE
),
stringsAsFactors = FALSE)
rownames(DF) <- c("One","Two","Three","Four","Five")
rhandsontable(DF,rowHeaderWidth = 96) %>%
hot_col("factor_allow", allowInvalid = TRUE)
Code version with Shiny:
library(rhandsontable)
library(shiny)
DF = data.frame(
integer = 1:5,
numeric = rnorm(5),
factor_allow = factor(letters[1:5],
levels = letters[5:1],
ordered = TRUE),
stringsAsFactors = FALSE
)
rownames(DF) <- c("One","Two","Three","Four","Five")
ui <- fluidPage(br(), rHandsontableOutput('my_table'))
server <- function(input, output, session) {
output$my_table <- renderRHandsontable({
rhandsontable(DF) %>%
hot_col("factor_allow", allowInvalid = TRUE)
})
}
shinyApp(ui,server)
I_O solution for code without Shiny (see Answers for solution for code with Shiny):
library(rhandsontable)
library(htmltools)
DF = data.frame(
integer = 1:5,
numeric = rnorm(5),
factor_allow = factor(letters[1:5],
levels = letters[5:1],
ordered = TRUE
),
stringsAsFactors = FALSE)
rownames(DF) <- c("One","Two","Three","Four","Five")
rhandsontable(DF,rowHeaderWidth = 96) %>%
hot_col("factor_allow", allowInvalid = TRUE)
browsable(
tagList(list(
tags$head(
tags$style("th{text-align:right !important; ## [1]
color:red !important}" ## [2]
)
),
my_table ## don't forget to specify widget
))
)

As you suggested, modifying the CSS is one approach. That should be possible via a renderer function, but you could also include custom CSS.
In your case, you'd probably best target the th element (the dedicated class .colHeader is applied to a <span> within which text aligning doesn't make much sense).
If you're serving the table as part of a Shiny app, here's how. Example:
ui <- fluidPage(
tags$head(
tags$style(HTML("
th{text-align:right !important;
width: 96px; ## you can specify the width here, too
"))
),
## ...
rHandsontableOutput('my_table')
## ...
)
In a larger project, you might prefer to maintain CSS styling in a separate file (see section File-based CSS of above ressource).
Otherwise, you could try this:
library(htmltools)
## ...
my_table <- rhandsontable(DF,rowHeaderWidth = 96) %>%
hot_col("factor_allow", allowInvalid = TRUE)
## ...
browsable(
tagList(list(
tags$head(
tags$style("th{text-align:right !important; ## [1]
color:red !important}" ## [2]
)
),
my_table ## don't forget to specify widget
))
)
[1] note the !important to override other definitions
[2] just to verify function at first glance, remove later ...

Display Text only on hover

I'm working on a shiny app in which I only want to want textouput on hover or mouse over action
I tried adding an action button
UI:
fluidRow(box (title = p("Rates by Gender and Race", actionButton("titleBtId", "", icon=icon('question-circle'),class = "btn-xs", title = "Info"),textOutput("text_id"),hover=T), width = 15, status = 'primary', solidHeader = TRUE,tabPanel('',plotlyOutput("racegender",height = "100%"))%>% withSpinner(color="#0dc5c1")))
Server:
output$text_id <- renderText({
paste0("hi")
})
I'm not sure how would I edit it to only display text on hover

An alternative to modal popups, depending on what user experience you want, is to use tooltips from the shinyBS package, which has functions for subtle but effective popups and tooltips. Here is an example of the different functionality of hovering or clicking, and putting the tooltips in the UI or in the server, with equivalent experience. Note that theoretically you could put a hover tooltip in the UI using tipify(), but for some reason this doesn't seem to be working with actionButtons though it continues to work for other input elements.
library(shiny)
library(shinyBS)
ui <- fluidPage(
titlePanel("ShinyBS tooltips"),
actionButton("btn", "On hover"),
tipify(actionButton("btn2", "On click"), "Hello again! This is a click-able pop-up", placement="bottom", trigger = "click")
)
server <- function(input, output, session) {
addTooltip(session=session,id="btn",title="Hello! This is a hover pop-up. You'll have to click to see the next one.")
}
shinyApp(ui, server)

Got it working using ModalDialog
UI
fluidRow(
box (title = p("Rates by Gender and Race", tags$head( tags$style(HTML('#titleBtId{background-color:black}'))), actionButton("titleBtId", "", icon=icon('question-circle'),class = "btn-xs", title = "Info"),hover=T), width = 15, status = 'primary', solidHeader = TRUE, tabPanel('',plotlyOutput("racegender",height = "100%"))%>% withSpinner(color="#0dc5c1")))
Server:
observeEvent(input$titleBtId, {
showModal(modalDialog(
title = "Note",
"This chart if independent of Date-range and Age-range selections",
easyClose = TRUE
))
})

How to adjust width of one column for shiny DataTables created with the JavaScript?

My Shiny App has a paging system, that allows to go back and forth. Below is a miniversion of my entire app. I would like to resize the first column of my datatable that includes checkboxes and make it at least half of the size as it is at this point, to allow for more space for the actual text in the second column.
How do you correctly adjust the first column?
I tried it within the renderdatatable command with:
columnDefs = list(list(targets= 0, width= '30px'). Did not work.
I also added
autoWidth= TRUE within options=list() as suggested here and here, however, that makes the entire table smaller. Below you can see how I included these within the code.
output$table_p2 <- DT::renderDataTable(
checkboxtable2,
server = FALSE, escape = FALSE, selection = 'none',
rownames = FALSE,
options = list(
dom = 't', paging = FALSE, ordering = FALSE,autoWidth = TRUE,
columnDefs = list(list(targets= 0, width= '30%')),
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } '))
)
I also tried to use the new syntax aoColumnDefs() as suggested here. Which I also could not make to work. How can I explicitly decrease the width of the first column?
ShinyApp
## miniversion of survey
if(!require(shiny))install.packages("shiny");require(shiny)
if(!require(shinyjs)) install.packages("shinyjs"); require(shiny)
if(!require(htmlwidgets)) install.packages("htmlwidgets"); require(htmlwidgets)
if(!require(shinyWidgets)) install.packages("shinyWidgets"); require(shinyWidgets)
if(!require(DT)) install.packages("DT"); require(DT)
answer_options = c("riding", "climbing", "travelling", "binge watching series", "swimming", "reading")
# https://stackoverflow.com/questions/37875078/shiny-checkbox-in-table-in-shiny/37875435#37875435
shinyInput <- function(FUN, ids, ...) {
inputs <- NULL
inputs <- sapply(ids, function(x) {
inputs[x] <- as.character(FUN(inputId = x, label = NULL, ...))
})
inputs
}
#
shinyApp(
ui = fluidPage( ####
useShinyjs(),# For Shinyjs functions
tags$script("
Shiny.addCustomMessageHandler('resetValue', function(variableName) {
Shiny.onInputChange(variableName, null);
});
"),
tags$style('{background-color: #256986;}'),
div(class="content",
# progressbar showing the progress of the survey, currently moves ahead per page in steps of
# 12.5 (excluding intro and thank you page)
progressBar(id= "pbar", value= 0, size= "xs"),
# main utput/ modified userinterface for each page
uiOutput("MainAction")
)
),
server =function(input, output, session) { ####
output$MainAction <- renderUI({
PageLayouts()
})
CurrentPage <- reactiveValues(page= "page1",
selected= 0)
PageLayouts<- reactive({
if(CurrentPage$page == "page1"){
return(
list(
textInput(inputId = "username", label= "Please enter your username"),
# button displayed to continue
div(class= "next button",actionButton(inputId = "p1_next", #input ID refers to following page
label= "Continue"))
))
}
if(CurrentPage$page == "page2"){
checkboxtable2 <- data.frame(
"answer options" = shinyInput(checkboxInput, answer_options),
"What are your hobbies?" = answer_options,
check.names = FALSE
)
output$table_p2 <- DT::renderDataTable(
checkboxtable2,
server = FALSE, escape = FALSE, selection = 'none',
rownames = FALSE,
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
columnDefs = list(list(targets= 0, width= '30px')),
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '))
)
return(
list(
# create datatable with checkboxes
p("What are your hobbies?"),
# create datatable with checkboxes
# surpresses header without removing checkboxes
tags$head(tags$style(type = "text/css", "#table_p2 th {display:none;}")),
DT::dataTableOutput('table_p2'),
updateProgressBar(session= session, id= "pbar", value = 12.5),
tags$style(".progress-bar {background-color: #25c484;}")
))
}
})
observeEvent(input$p1_next, {CurrentPage$page <- "page2"})
})
Comment in case you are wondering about the construction of the datatable: The procedure I follow to create these tables is to create dataframes first out of two vectors (one of which includes the checkboxes), transform these into DataTables with renderDataTable, followed by returning the table without the header by overwriting its CSS in a list. I had to follow this procedure, as all other methods to return a checkbox table without a header row, resulted in a data table without checkboxes. Therefore, the code had to be split as I could not create vectors with checkboxes in a list.

DataTables are not very nice, when it comes to column widths. It sais here that widths will never be taken literally from the given definition, but always adapted to the table size and what not. Thats why your efforts were in vain.
But you can still shape things to your need. At first, using checkboxInput creates a container around the checkbox that has a default width of 300 pixels, which are the main reason for the column to be so big. You could in a first step unset this width to see what "natural" size the column would have.
If you want to reduce the size even more, a css rule for the column's width is working fine. For that and the above part, we equip the first column cells with a specific class name.
Weave
columnDefs = list(list(targets = 0, className = "small" ))
into your DataTable definition and then add
td.small .shiny-input-container{width:auto;}
to your css to unset the predefined width in this column.
Further minifications can be achieved by the css rule
td.small{width:30px;}

Link (not node) tooltips in networkD3's forceNetwork and htmlwidgets

My searches for a way to attach tooltips to the links (i.e. edges) between nodes using forceNetwork are coming up empty. These are the most relevant examples I've found:
How to add tooltips to sankeyNetwork links:
Displaying edge information in Sankey tooltip
How to add tooltips forceNetwork nodes:
Implementing tooltip for networkD3 app
So how do you add tooltips to forceNetwork links? Is it possible? I see that forceNetwork has a clickAction attribute that you can use to call JS with htmlwidgets. Unfortunately, clickAction seems to act on nodes, not the links between them.
Here is my reproducible example:
library(networkD3)
library(htmlwidgets)
# Load data
data(MisLinks)
data(MisNodes)
# Make network using sample data
fn <- forceNetwork(
Links = MisLinks, Nodes = MisNodes,
Source = "source", Target = "target",
Value = "value", NodeID = "name",
Group = "group"
)
# Get the target variable in fn$x$links (an integer id) to show up as a tooltip when user hovers over a link (i.e. edge) in the graph
fnrender <- htmlwidgets::onRender(
fn,
'
function(el, x) {
d3.selectAll(".link").select("title")
.text(function(d) { return d.target; });
}
'
)
# display the result
fnrender
My goal is to have a string variable describing the relationship between 2 nodes show up when the user hovers over the link between them. Any suggestions on how to move forward would be much appreciated.

You have to 'append' the title...
library(networkD3)
library(htmlwidgets)
# Load data
data(MisLinks)
data(MisNodes)
# Make network using sample data
fn <- forceNetwork(
Links = MisLinks, Nodes = MisNodes,
Source = "source", Target = "target",
Value = "value", NodeID = "name",
Group = "group"
)
# Get the target variable in fn$x$links (an integer id) to show up as a tooltip when user hovers over a link (i.e. edge) in the graph
fnrender <- htmlwidgets::onRender(
fn,
'
function(el, x) {
d3.selectAll(".link").append("svg:title")
.text(function(d) { return d.source.name + " -> " + d.target.name; })
}
'
)
# display the result
fnrender

update column visibility in DT::datatable while using DT::replaceData

Is there a way (other than a 'colvis' button) to dynamically update which columns are visible in a DT::datatabe while using the DT::replaceData to update the table?
(The reason I can not use the 'colvis' button (as shown here:https://rstudio.github.io/DT/extensions.html) is I need to have a few different short cut convenient buttons that hide and show multiple complex patterns at once.)
This is an example of how I would initiate my app. Is there a way in js or the server-side to hide and show columns? Thanks!
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
fluidRow(
column(2, actionButton('refresh', 'Refresh Data', icon = icon('refresh'))),
column(10, DT::dataTableOutput('foo'))
)
),
server = function(input, output, session) {
df = iris
n = nrow(df)
df$ID = seq_len(n)
loopData = reactive({
input$refresh
df$ID <<- c(df$ID[n], df$ID[-n])
df
})
output$foo = DT::renderDataTable(isolate(DT::datatable(loopData(),
options = list(
columnDefs = list(list(visible=FALSE,targets=c(0,1,2))))
)))
proxy = dataTableProxy('foo')
observe({
replaceData(proxy, loopData(), resetPaging = FALSE)
})
}
)