I am experimenting with gWidgets in R and simply trying to open a new gwindow for different values of selected option in gradio. There are 3 options and the last two work fine. When I select the first option, the error displayed is as follows.
Error in tkobj$env : $ operator is invalid for atomic vectors
I have tried to include the choices as a list too, but the error remains. The rest of the code is as follows. Any suggestions would be helpful.
library(gWidgets)
library(base)
options("guiToolkit"="tcltk")
win1<-gwindow("Welcome to OCCUR", visible = TRUE)
g0<-ggroup(container = win1)
g1 <- ggroup(container = win1)
g2 <-ggroup (container = win1)
l1<-glabel(text = "Please select one.",editable = FALSE,
container = g0,toolkit = guiToolkit())
#radio buttons
radiob<- gradio(c("Customer Data", "Sales Analysis",
"Market Basket Analysis"), horizontal = FALSE, container = g1)
#exit ok buttons
b1<- gbutton("Let's go", container = g2 , handler = newwin)
newwin <- function(svalue){
if(svalue(radiob)=="Customer Data"){
win2<-gmenu("1 ", visible = TRUE)
}
if(svalue(radiob)=="Sales Analysis"){
win2<-gwindow("1", visible = TRUE)
}
else{
win2<-gwindow(" 3", visible = TRUE)
}
}
b2<- gbutton("Exit", container=g2, handler = exit)
exit<-function(h,...){
dispose(win1)
}
Related
I want to put the focus and edit the first cell of my dynamic table when the user clicks a button.
the problem is that the id of the table tag is dynamic. actually, the name I put in dtoutput is a div tag, which contains neither cell nor row to position with javascrpt.
The problem is that the identification of the html tag of the table is dynamic. Actually, the name that I put in dtoutput is a div tag, and therefore its javascrpt object does not contain a cell or a row to position.
I have tried to position myself in different ways:
# tablet_list_var_dtf.cell (': eq (0)'). node (). focus ();
# tablet_list_var_dtf.cell (': eq (1)', ': eq (0)') .focus ();
# tablet_list_var_dtf.cell (': eq (' + scrollStart + ')', ': eq (0)') .focus ();
but as I say, really 'tablet_list_var_dtf' is an HTMLDivElement object and therefore it does not have node, cell, row etc ... also I cannot directly use object.focus (), it does not work.
Not only do I want to put the focus, but I want to edit the first cell, force a doubleclick event on said cell ..
I put a summary and executable code of the problem
enter code here
library(shiny)
library(DT)
library(shinyjs)
library(shinyFeedback)
# JS refocus function
jscode <- "
shinyjs.refocus = function(e_id ) {
alert(e_id);
alert(eval(tablet_list_var_dtf));
tablet_list_var_dtf.datatable.row().focus();
var scrollStart = tablet_list_var_dtf.scroller.page().start;
alert('ppp:'+scrollStart);
}"
#tablet_list_var_dtf.cell(':eq(0)').node().focus();
#tablet_list_var_dtf.cell( ':eq(1)', ':eq(0)' ).focus();
#tablet_list_var_dtf.cell( ':eq(' + scrollStart + ')', ':eq(0)' ).focus();
#table.cell(':eq(0)').focus()
#shinyjs.refocus = function(e_id) {
#document.getElementById(e_id).focus();
ui <- fluidPage(
useShinyjs(),
extendShinyjs(text = jscode, functions = c("refocus") ),
# activate shiny feedback
box(wclass = "map",
width = 12,
style = 'padding:0px;',
title = "List of DTF",
uiOutput( ("list_var_dtf"))
) ,
actionButton( ('edit_name_var_dtf'),'edit name var description'),
)
server <- function(input, output, session){
observeEvent(input$edit_name_var_dtf, {
print("edit_name_var_dtf")
js$refocus("tablet_list_var_dtf")
print('js$refocus(table)')
})
output$list_var_dtf <- renderUI({
DTOutput(("tablet_list_var_dtf"))
})
output$tablet_list_var_dtf <- renderDT(
datatable( data = mtcars,
rownames = FALSE,
options = list(
orderClasses = TRUE,
order = list(1, "desc"),
scrollX = TRUE,
scrollY = "37vh",
searchHighlight = TRUE,
scrollCollapse = T,
dom = 'ft',
paging = FALSE,
#callback = JS(jscall),
initComplete = JS("function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#000', 'color': '#fff'});",
"}")
),
selection = "none" , editable = list(target = "column", disable = list(columns = c(1))))
)
}
shinyApp(ui, server)
This is the js code correct:
jscode <- " shinyjs.refocus = function(e_id){
var table = $('#DataTables_Table_0').DataTable();
var td = table.cell(':eq(0)', ':eq(0)').node();
$(td).attr('tabindex', 0); $(td).dblclick( );
}"
The problem is looking for the 'DataTables_Table_(XXX)' selector in a pivot table in shiny. So the real problem is finding the right selector for the table.
If our component id is 'table_list_var_dtf'
DTOutput('table_list_var_dtf')
you should know that this id is not really the id of the table. But the id of the div that contains the pivot table. Specifically, the table that is created dynamically starts with the name DataTables_Table_ (xxxxxx) . Where (xxxxxx) is the number of tables that have been created dynamically.
Thus, if there are only two tables on the page, the id to look for is: DataTables_Table_ 02
thankssss. jogugil...
I'm creating a datatable in R which has child rows, manually-defined column names and also hides a few columns.
This seemed fairly trivial based on an example provided in the DT manual https://rstudio.github.io/DT/002-rowdetails.html (i.e. it already shows how to create the child rows and hide some of the columns). However, when I try adding the 'colnames' argument to define the new column names of the non-hidden columns it doesn't behave as expected.
I have tried removing the blank column header text, adding extras to see if it's relating to the original number of columns in the table. If I remove the call to hide certain columns the headers show as they should but I can't delete columns (they need to be hidden) because the table is linked to plot objects that use the data from those hidden columns.
library(DT)
datatable(
cbind(' ' = '⊕', mtcars), escape = -2,
colnames = c(" ", "GEAR COLUMN", "CARB COLUMN"), # This is the only line added to the original DT example.
options = list(
columnDefs = list(
list(visible = FALSE, targets = c(0, 2, 3:10)), # Removing this line solves the header issue but then all columns are shown.
list(orderable = FALSE, className = 'details-control', targets = 1)
)
),
callback = JS("
table.column(1).nodes().to$().css({cursor: 'pointer'});
var format = function(d) {
return '<div style=\"background-color:#eee; padding: .5em;\"> Model: ' +
d[0] + ', mpg: ' + d[2] + ', cyl: ' + d[3] + '</div>';
};
table.on('click', 'td.details-control', function() {
var td = $(this), row = table.row(td.closest('tr'));
if (row.child.isShown()) {
row.child.hide();
td.html('⊕');
} else {
row.child(format(row.data())).show();
td.html('⊖');
}
});"
))
No error messages are provided, it just displays as normal but without all the defined column headers.
I suspect this is a relatively simple thing that makes perfect sense to those experienced in the JS call, but unfortunately that's not my forte.
If you want to rename the gear and the carb columns, you can do
colnames = c("GEAR COLUMN" = "gear", "CARB COLUMN" = "carb")
I would like to create dynamic tabs, where each time the user clicks a button, a new tab would be created. Each tab has the same content, with a variety of widgets that the user can use to select which sets of data to be plotted.
Currently, I am using the solution here to dynamically create my tabs, but with the change that lapply is calling a function that calls tabPanel and adds content to the tabs
`
renderUI({
some_data <- # Dataframe that data is extracted goes here
createTabs <- function(tabNum, some_data)
{
tabPanel(title = paste("Map", tabNum, sep=" "),
fluidRow(
column(
width = 3,
wellPanel(
#widgets are added here
}
mTabs <- lapply(0:input$map, createTabs, some_data)
do.call(tabsetPanel, mTabs)
})
`
And the methods of for loops posted here to create the plots on each tab.
However, it seems like instead of creating a new tab, the 2 solutions above both re-create all the existing tabs. So if there are currently 10 tabs open, all 10 tabs get re-created. Unfortunately, this also resets all the user settings on each tab (in addition to slowing down the app), and extra provisions must be taken as shown here , which further slows down the app because of the large number of input objects that must be created.
I saw a solution for menu items that seems to solve this problem by simply storing all the menu items in a list, and each time a new menu item is generated, it is simply added to the list so that all the other existing items don't need to be created. Is something like this possible for tabs and rendering plots as well?
This is the code:
newTabs <- renderMenu({
menu_list <- list(
menu_vals$menu_list)
sidebarMenu(.list = menu_list)
})
menu_vals = reactiveValues(menu_list = NULL)
observeEvent(eventExpr = input$placeholder,
handlerExpr = {
menu_vals$menu_list[[input$placeholder]] <- menuSubItem(paste("Saved Simulation", length(menu_vals$menu_list) + 1, sep = " "),
tabName = paste("saved_sim", length(menu_vals$menu_list) + 1))
})
If someone can explain to me what menu_list <- list(menu_vals$menu_list) is doing , why Rstudio says it must be inside a reactive expression, and why a new list called menu_vals is created with menu_list = null, it would be greatly appreciated as well :)
Edit: I think I was able to prevent the plots from being re-created each time a new tab is created and also bypass the need for a max number of plots using
observeEvent(eventExpr = input$map,
handlerExpr = {
output[[paste0("outputComparePlot",simNum,"-",input$map)]] <- outputComparePlot(sessionEnv, config, react, input, simNum, input$map) #This function contains the call to renderPlot
})
However, I still cannot figure out how to use this for creating tabs. I tried the same method but it didnt work.
I would like to present a solution that adds a feature to shiny which should have been implemented into shiny base long ago. A function to append tabPanels to existing tabsetPanels. I already tried similar stuff here and here, but this time, I feel like this solution is way more stable and versatile.
For this feature, you need to insert 4 parts of code into your shiny app. Then you can add any set of tabPanels each having any content to an existing tabsetPanel by calling addTabToTabset. Its arguments are a tabPanel (or a list of tabPanels) and the name (id) of your target tabsetPanel. It even works for navbarPage, if you just want to add normal tabPanels.
The code which should be copy-pasted, is inside the "Important!" comments.
My comments will probably not be enough to grasp what's really happening (and why, of course). So if you want to get more into detail, please leave a message and I will try to elaborate.
Copy-Paste-Run-Play!
library(shiny)
ui <- shinyUI(fluidPage(
# Important! : JavaScript functionality to add the Tabs
tags$head(tags$script(HTML("
/* In coherence with the original Shiny way, tab names are created with random numbers.
To avoid duplicate IDs, we collect all generated IDs. */
var hrefCollection = [];
Shiny.addCustomMessageHandler('addTabToTabset', function(message){
var hrefCodes = [];
/* Getting the right tabsetPanel */
var tabsetTarget = document.getElementById(message.tabsetName);
/* Iterating through all Panel elements */
for(var i = 0; i < message.titles.length; i++){
/* Creating 6-digit tab ID and check, whether it was already assigned. */
do {
hrefCodes[i] = Math.floor(Math.random()*100000);
}
while(hrefCollection.indexOf(hrefCodes[i]) != -1);
hrefCollection = hrefCollection.concat(hrefCodes[i]);
/* Creating node in the navigation bar */
var navNode = document.createElement('li');
var linkNode = document.createElement('a');
linkNode.appendChild(document.createTextNode(message.titles[i]));
linkNode.setAttribute('data-toggle', 'tab');
linkNode.setAttribute('data-value', message.titles[i]);
linkNode.setAttribute('href', '#tab-' + hrefCodes[i]);
navNode.appendChild(linkNode);
tabsetTarget.appendChild(navNode);
};
/* Move the tabs content to where they are normally stored. Using timeout, because
it can take some 20-50 millis until the elements are created. */
setTimeout(function(){
var creationPool = document.getElementById('creationPool').childNodes;
var tabContainerTarget = document.getElementsByClassName('tab-content')[0];
/* Again iterate through all Panels. */
for(var i = 0; i < creationPool.length; i++){
var tabContent = creationPool[i];
tabContent.setAttribute('id', 'tab-' + hrefCodes[i]);
tabContainerTarget.appendChild(tabContent);
};
}, 100);
});
"))),
# End Important
tabsetPanel(id = "mainTabset",
tabPanel("InitialPanel1", "Some Text here to show this is InitialPanel1",
actionButton("goCreate", "Go create a new Tab!"),
textOutput("creationInfo")
),
tabPanel("InitialPanel2", "Some Text here to show this is InitialPanel2 and not some other Panel")
),
# Important! : 'Freshly baked' tabs first enter here.
uiOutput("creationPool", style = "display: none;")
# End Important
))
server <- function(input, output, session){
# Important! : creationPool should be hidden to avoid elements flashing before they are moved.
# But hidden elements are ignored by shiny, unless this option below is set.
output$creationPool <- renderUI({})
outputOptions(output, "creationPool", suspendWhenHidden = FALSE)
# End Important
# Important! : This is the make-easy wrapper for adding new tabPanels.
addTabToTabset <- function(Panels, tabsetName){
titles <- lapply(Panels, function(Panel){return(Panel$attribs$title)})
Panels <- lapply(Panels, function(Panel){Panel$attribs$title <- NULL; return(Panel)})
output$creationPool <- renderUI({Panels})
session$sendCustomMessage(type = "addTabToTabset", message = list(titles = titles, tabsetName = tabsetName))
}
# End Important
# From here: Just for demonstration
output$creationInfo <- renderText({
paste0("The next tab will be named NewTab", input$goCreate + 1)
})
observeEvent(input$goCreate, {
nr <- input$goCreate
newTabPanels <- list(
tabPanel(paste0("NewTab", nr),
actionButton(paste0("Button", nr), "Some new button!"),
textOutput(paste0("Text", nr))
),
tabPanel(paste0("AlsoNewTab", nr), sliderInput(paste0("Slider", nr), label = NULL, min = 0, max = 1, value = 1))
)
output[[paste0("Text", nr)]] <- renderText({
if(input[[paste0("Button", nr)]] == 0){
"Try pushing this button!"
} else {
paste("Button number", nr , "works!")
}
})
addTabToTabset(newTabPanels, "mainTabset")
})
}
shinyApp(ui, server)
Probably thanks to #k-rohde, there's now natively available in Shiny a set of methods to add/remove/append tabs in a tabset:
library(shiny)
runApp(list(
ui=fluidPage(
fluidRow(
actionLink("newTab", "Append tab"),
actionLink("removeTab", "Remove current tab")
),
tabsetPanel(id="myTabs", type="pills")
),
server=function(input, output, session){
tabIndex <- reactiveVal(0)
observeEvent(input$newTab, {
tabIndex(tabIndex() + 1)
appendTab("myTabs", tabPanel(tabIndex(), tags$p(paste("I'm tab", tabIndex()))), select=TRUE)
})
observeEvent(input$removeTab, {
removeTab("myTabs", target=input$myTabs)
})
}
))
I am working on the r panel package. Now if I have a function that uses a radiogroup button, and if i attempt to run the function from inside the rpanel menu, I get this error:
Error in panel$intname : $ operator is invalid for atomic vectors
However if I run the function per sé i.e. not from inside the rpanel menu, but by calling it independently, the above error doesn't appear. Here is a simple example. Try in 2 ways (1) run the whole code and click on Addition and then click Add in the menu (2) run the add function alone and call with add(). The former results in the above error and the latter doesn't. Also, i saw that this error comes only when i have a rp.radiogroup in my panel.
I saw the post in Why doesn't R allow $ operator on atomic vectors? but how do i solve my issue? My sample Code is below:
install.packages(c("rpanel","tkrplot"))
my.menu <- function(panel) {
library(rpanel,tkrplot)
if (panel$menu=="Add"){
add()
}
else
panel
}
main.panel <- rp.control(title = "Main Menu",size=c(200,150))
rp.menu(panel = main.panel, var = menu,
labels = list(list("Addition", "Add")),action = my.menu)
# function to do adddition
add <- function(){
my.draw <- function(panel) {
if(panel$vals=="numbers"){
val<-as.numeric(panel$nmbr1)+as.numeric(panel$nmbr2)
}
else if(panel$vals=="strings"){
val <- paste(as.character(panel$nmbr1), "and" ,as.character(panel$nmbr2))
}
plot(1:10, 1:10, type="n", xlab="", ylab="",
axes=FALSE, frame = TRUE)
text(5, 5, paste("Result: ", val),cex=1.4)
panel
}
my.redraw <- function(panel) {
rp.tkrreplot(panel, my.tkrplot)
panel
}
my.panel <- rp.control(title = "Addition")
rp.textentry(panel = my.panel, var = nmbr1,
labels = "First: ", action = my.redraw, initval="100")
rp.textentry(panel = my.panel, var = nmbr2,
labels = "Second:", action = my.redraw, initval="200")
rp.radiogroup(panel = my.panel, var = vals,
values = c("numbers", "strings"),
action = my.redraw, title = "Type")
rp.tkrplot(panel = my.panel, name = my.tkrplot, plotfun = my.draw)
}
You may simply escape using $: Change
panel$vals
to:
panel["vals"]
How can I create mouseover text for column names in R shiny data table display.
I'm trying to provide some text for users to understand the column names.
I checked in DT package also and I couldn't find a solution.
I can create labels for column names and display all of them when a user checks a box, this takes a lot of real estate and I don't want that.
Any tips?
To expand my comment above, here is an example showing what I meant by using the title attributes:
library(DT)
sketch = htmltools::withTags(table(
class = 'display',
thead(
tr(
th('', title = 'Row Names'),
th('Sepal.Length', title = 'The Sepal Length'),
th('Sepal.Width', title = 'The Sepal Width'),
th('Petal.Length', title = 'The Petal Length'),
th('Petal.Width', title = 'The Petal Width'),
th('Species', title = 'Iris Species')
)
)
))
datatable(iris, container = sketch)
And here is another approach using JavaScript (jQuery) to add the title attributes:
library(DT)
datatable(iris, callback = JS("
var tips = ['Row Names', 'The Sepal Length', 'The Sepal Width',
'The Petal Length', 'The Petal Width'],
header = table.columns().header();
for (var i = 0; i < tips.length; i++) {
$(header[i]).attr('title', tips[i]);
}
"))
You can probably accomplish that using optionsin the renderDataTable() function in Shiny. From the documentation page of DT in Shiny, something like this should work.
renderDataTable(head(iris, 20), options = list(
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).on({
mouseenter: function () {
//stuff to do on mouse enter
},
mouseleave: function () {
//stuff to do on mouse leave
}
});",
"}")
))