Highlight/find data points in plotly scatter from the browser - r

I generated a scatterplot in HTML format using plotly and a generic dataframe. I am aware that it is possible to highlight (with a different color for example) certain data points before generating the plot HTML. However, I wonder if it is possible to add an element to the HTML file that would enable a user to find/highlight a certain data point based on its text label after the plot has been produced.
The code I used to produce the dataframe and scatter:
tab <- data.frame(sample.id = pca$sample.id,
EV1 = pca$eigenvect[, 1],
EV2 = pca$eigenvect[, 2],
stringsAsFactors=F)
p <- plot_ly(tab, x=tab$EV1, y=tab$EV2, text=tab$sample.id)
p <- layout(p, title="PCA", xaxis=list(title="PC 1"),
yaxis=list(title="PC 2"))
htmlwidgets::saveWidget(as.widget(p), paste(output_name, ".html", sep=""))

As far as I know there is not builtin functionality in Plotly but you just need a few lines of Javascript code to get the functionality.
Plotly stores the data in a application/json object in the HTML file. You can get the data via
var data = JSON.parse(document.querySelectorAll("script[type='application/json']")[0].innerHTML);
The text elements are stored in
data.x.data[i].text[j]
where i is the trace number and j is point number.
Now we need a text field and a button, we can use htmltools for that purpose
p <- htmlwidgets::appendContent(p, htmltools::tags$input(id='inputText', value='Merc', ''), htmltools::tags$button(id='buttonSearch', 'Search'))
Let's add a eventlister to the button which triggers a hover event of the first point of the first trace.
p <- htmlwidgets::appendContent(p, htmltools::tags$script(HTML(
'document.getElementById("buttonSearch").addEventListener("click", function()
{
var myDiv = document.getElementsByClassName("js-plotly-plot")[0]
Plotly.Fx.hover(myDiv, [{curveNumber: 0, pointNumber: 0}]);
}
)
')))
And the whole code which searches for through all text labels and triggers a hover event when the entered text is found in the label.
library(plotly)
library(htmlwidgets)
library(htmltools)
pcaCars <- princomp(mtcars, cor = TRUE)
carsHC <- hclust(dist(pcaCars$scores), method = "ward.D2")
carsDf <- data.frame(pcaCars$scores, "cluster" = factor(carsClusters))
carsClusters <- cutree(carsHC, k = 3)
carsDf <- transform(carsDf, cluster_name = paste("Cluster", carsClusters))
p <- plot_ly(carsDf, x = ~Comp.1 , y = ~Comp.2, text = rownames(carsDf),
mode = "markers", color = ~cluster_name, marker = list(size = 11), type = 'scatter', mode = 'markers')
p <- htmlwidgets::appendContent(p, htmltools::tags$input(id='inputText', value='Merc', ''), htmltools::tags$button(id='buttonSearch', 'Search'))
p <- htmlwidgets::appendContent(p, htmltools::tags$script(HTML(
'document.getElementById("buttonSearch").addEventListener("click", function()
{
var i = 0;
var j = 0;
var found = [];
var myDiv = document.getElementsByClassName("js-plotly-plot")[0]
var data = JSON.parse(document.querySelectorAll("script[type=\'application/json\']")[0].innerHTML);
for (i = 0 ;i < data.x.data.length; i += 1) {
for (j = 0; j < data.x.data[i].text.length; j += 1) {
if (data.x.data[i].text[j].indexOf(document.getElementById("inputText").value) !== -1) {
found.push({curveNumber: i, pointNumber: j});
}
}
}
Plotly.Fx.hover(myDiv, found);
}
);')))
htmlwidgets::saveWidget(p, paste('pca', ".html", sep=""))
p
The PCA implementation was modified from here.

Related

r plotly update button with line plot does not work with add_markers

I have a problem with the joined plot of an updatable line and static markers in R plotly. The line plot is updated via a drop down menu button, which works well on its own. The additional dots in the add_markers function are also correct when the plot is first initialized.
But after the first update, the markers are cut off (to the left side of the plot where the line starts) and remaining markers are modified (y values are different to initial ones).
For the example here the button function is simplified, but the result shows the same strange behavior.
`
sample_df <- tibble::tibble(quarter_date = rep(c("2022-06-30","2022-09-30","2022-12-31"),3),
forecast_value = runif(9,min = 10,max = 16),
forecast_date = c(rep("2022-07-23",3),rep("2022-08-26",3),rep("2022-09-15",3)))
marks = tibble::tibble(dates = c("2022-05-21","2022-06-15","2022-07-02","2022-07-26","2022-08-27"),
values = c(11,13,12,15,14))
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id,df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>%
dplyr::filter(forecast_date == date_id) %>%
dplyr::pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
plotly::plot_ly(x = ~quarter_date) %>%
plotly::add_trace(data = sample_df %>%
dplyr::filter(forecast_date == max(forecast_date)),
#x = ~period_date,
y = ~forecast_value,
type = 'scatter',
mode = 'markers+lines',
name = 'forecasts') %>%
plotly::layout(
title = "Drop down menue",
yaxis = list(title = "y"),
updatemenus = list(
list(
y =1,
x = 0.9,
buttons = create_buttons(sample_df, unique(sample_df$forecast_date))
)
)) %>%
plotly::add_markers(data = marks,
x = ~dates,
y = ~values)
`
I have tried to set a wide xrange, used a second y2 axis and different approaches in the button calculation but nothing works as intended.
Does anyone have a clue why the add_markers is not working correctly after updating the line plot? Any ideas are highly appreciated!
Adding markers aren't the issue. The issue comes from the restyle. When you restyle the plot without designating that you only meant to change one trace, you changed all traces.
The solution is actually quite simple, you just need one more argument in your args call-- the trace number in a list: list(0) in this case. I've commented out your original args call, so you can see the change.
To make this repeatable, I added set.seed(46) before the creation of sample_df.
create_buttons <- function(df, date_id) {
lapply(
date_id,
FUN = function(date_id, df) {
button <- list(
method = 'restyle',
args = list('y', list(df %>% filter(forecast_date == date_id) %>%
pull(forecast_value)), list(0)),
# args = list('y', list(df %>%
# filter(forecast_date == date_id) %>%
# pull(forecast_value))),
label = sprintf('Forecast # %s', date_id)
)
},
df
)
}
Now when you run your plot, you will see that your marker data remains visible.

Plotly: text is overwritten when traces are added using for loops

I have created a plotly scatter plot which I add traces to using a for loop. When I add text labels or hoverinfo, the text for the last point overwrites all others. Does anyone know how to prevent this?
I have created a reproducible example below where the (correctly named) blue points are created outside the loop however the red points created within the loop have their names overwritten (all incorrectly labelled E as opposed to A->E):
library(plotly)
data.frame1 <- data.frame("name"=paste("name", LETTERS[6:10]), "x"=-1:-5, "y"=-1:-5)
data.frame2 <- data.frame("name"=paste("name", LETTERS[1:5]), "x"=1:5, "y"=1:5)
p <- plot_ly(data.frame1, x = ~x, y = ~y, text = ~paste0(name),
name = "Outside loop", type ="scatter",
mode = "markers+text", marker=list(color="blue") )
for(i in 1:nrow(data.frame2)) {
point <- data.frame2[i, ]
p <- p %>% add_trace(x = point$x, y = point$y, text = ~paste0(point$name),
type ="scatter", mode = "markers+text",
marker = list(color="red", size=10),
name=point$name )
}
p
The ~ sign causes the problem, remove in the loop and it should be fine. It makes sense when you refer to your data frame like in the first example but it causes the weird behavior you are observing in the loop.
library(plotly)
data.frame1 <- data.frame("name"=paste("name", LETTERS[6:10]), "x"=-1:-5, "y"=-1:-5)
data.frame2 <- data.frame("name"=paste("name", LETTERS[1:5]), "x"=1:5, "y"=1:5)
p <- plot_ly(data.frame1, x = ~x, y = ~y, text = ~paste0(name),
name = "Outside loop", type ="scatter",
mode = "markers+text", marker=list(color="blue") )
for(i in 1:nrow(data.frame2)) {
point <- data.frame2[i, ]
print(paste0(point$name))
p <- p %>% add_trace(x = point$x, y = point$y, text = paste0(point$name),
type ="scatter", mode = "markers+text",
marker = list(color="red", size=10),
name=point$name )
}
p

How do you create a bar and line plot with R dygraphs?

I would like to create a bar and line chart using dygraphs, which seems like it should be possible based on the "Bar & Line Chart" dygraphs example here, and the dyBarChart() custom plotter provided in the dygraphs package.
Using the custom wrapper, I can create a barplot, so I think that code is working:
library(dygraphs)
dyBarChart <- function(dygraph) {
dyPlotter(
dygraph = dygraph,
name = "BarChart",
path = system.file("examples/plotters/barchart.js",package = "dygraphs")
)
}
lungDeaths <- cbind(ldeaths, mdeaths)
dygraph(lungDeaths) %>%
dyBarChart()
I assumed that I could then use dySeries() to customize the series I wanted to show up with a line/bar, but neither of the following work. They do not error out, but nothing is created. I'm also not sure if the "linePlotter" is the correct plotter name, but either way, I need a little help.
# doesn't work
dygraph(lungDeaths) %>%
dyBarChart() %>%
dySeries("ldeaths", plotter = "linePlotter")
# also doesn't work:
dygraph(lungDeaths) %>%
dySeries("ldeaths", plotter = "dyBarChart") %>%
dySeries("mdeaths", color = "blue")
Thanks.
Sometimes you get lucky… I‘ve worked on the same thing a couple of weeks ago and I‘ve found that the documentation is not quite clear on how to do it. But you were pretty close yourself.
How to do it – step by step:
You have to set the plotter for each dyseries
The plotter argument in the dyseries command does not take functions names. But it needs to be a javascript function as plain text
Stacking the bars is easier. Multibars need a way to pass an argument to the javascript function, which you cannot do directly in the package. So I had to do a workaround (At least I found no better way to do it in R).
BTW, setting the dyPlotter command did not work because it sets the plotter globally for all dySeries in the plot. At least that‘s what I figure it does.
So without further ado, here‘s my code. I have added some more test data just to show all the functions.
Test data:
library(xts)
library(dygraphs)
test<-xts(matrix(rnorm(100*4), ncol=4, nrow=100), order.by=seq.POSIXt(as.POSIXct("2017-01-01 00:00", tz="UTC"),by=3600, length.out = 100))
colnames(test)<-c("Series_A","Series_B", "Series_C", "Series_D")
Functions:
dy_position<-function(data_final, plot_title, y2_names=NULL, y1_label, y2_label, y1_step=F, y2_step=F, stacked=T){
data_final<-reorder_xts(data_final, y2_names) #reorder necessary so that all y2 are at the right end of the xts. Needed for the multibar plot
dyg <- dygraphs::dygraph(data_final, main=plot_title)
dyg <- dygraphs::dyAxis(dyg, "x", rangePad=20)
dyg <- dygraphs::dyAxis(dyg, "y", label = y1_label,
axisLabelWidth = 90)
y1_names<-colnames(data_final)[!(colnames(data_final) %in%y2_names)]
if (length(y1_names)==1){
stacked<-T #in this case only stacking works
}
if (stacked){
dyg <- dygraphs::dyOptions(dyg,stepPlot=y1_step,stackedGraph = T)
for(i in seq_along(y1_names)) {
dyg <- dygraphs::dySeries(dyg, y1_names[i], axis = "y", strokeWidth = 1.5, stepPlot = y1_step, plotter=" function barChartPlotter(e) {
var ctx = e.drawingContext;
var points = e.points;
var y_bottom = e.dygraph.toDomYCoord(0);
ctx.fillStyle = e.color;
// Find the minimum separation between x-values.
// This determines the bar width.
var min_sep = Infinity;
for (var i = 1; i < points.length; i++) {
var sep = points[i].canvasx - points[i - 1].canvasx;
if (sep < min_sep) min_sep = sep;
}
var bar_width = Math.floor(2.0 / 3 * min_sep);
// Do the actual plotting.
for (var i = 0; i < points.length; i++) {
var p = points[i];
var center_x = p.canvasx;
ctx.fillRect(center_x - bar_width / 2, p.canvasy,
bar_width, y_bottom - p.canvasy);
ctx.strokeRect(center_x - bar_width / 2, p.canvasy,
bar_width, y_bottom - p.canvasy);
}
}")
}
} else {
dyg <- dygraphs::dyOptions(dyg,stepPlot=y1_step)
for(i in seq_along(y1_names)) {
#plotter in function
dyg <- dygraphs::dySeries(dyg, y1_names[i], axis = "y", strokeWidth = 1.5, stepPlot = y1_step, plotter =multibar_combi_plotter(length(y2_names)))
}
}
# put stuff on y2 axis
dyg <- dygraphs::dyAxis(dyg, "y2", label = y2_label, independentTicks = T)
for(i in seq_along(y2_names)) {
dyg <- dygraphs::dySeries(dyg, y2_names[i], axis = "y2", strokeWidth = 1.5, stepPlot = y2_step)
}
return(dyg)
}
#we need to take into account all values and then leave out the ones we do not like
multibar_combi_plotter<-function(num_values){
#plotter function
plotter_text<-"function multiColumnBarPlotter(e) {
// We need to handle all the series simultaneously.
if (e.seriesIndex !== 0) return;
var g = e.dygraph;
var ctx = e.drawingContext;
var sets = e.allSeriesPoints;
var y_bottom = e.dygraph.toDomYCoord(0);
// Find the minimum separation between x-values.
// This determines the bar width.
var min_sep = Infinity;
for (var j = 0; j < sets.length-%s; j++) {
var points = sets[j];
for (var i = 1; i < points.length; i++) {
var sep = points[i].canvasx - points[i - 1].canvasx;
if (sep < min_sep) min_sep = sep;
}
}
var bar_width = Math.floor(2.0 / 3 * min_sep);
var fillColors = [];
var strokeColors = g.getColors();
for (var i = 0; i < strokeColors.length; i++) {
fillColors.push(strokeColors[i]);
}
for (var j = 0; j < sets.length-%s; j++) {
ctx.fillStyle = fillColors[j];
ctx.strokeStyle = strokeColors[j];
for (var i = 0; i < sets[j].length; i++) {
var p = sets[j][i];
var center_x = p.canvasx;
var x_left = center_x - (bar_width / 2) * (1 - j/(sets.length-%s-1));
ctx.fillRect(x_left, p.canvasy,
bar_width/sets.length, y_bottom - p.canvasy);
ctx.strokeRect(x_left, p.canvasy,
bar_width/sets.length, y_bottom - p.canvasy);
}
}
}"
custom_plotter <- sprintf(plotter_text, num_values, num_values, num_values)
return(custom_plotter)
}
reorder_xts<-function(xts_series,line_names){
bar_names<-colnames(xts_series)[!(colnames(xts_series)%in%line_names)]
xts_series<-xts_series[,c(bar_names,line_names)]
return(xts_series)
}
Some Explanation:
dy_position does all the plotting. It uses individual plotters per series axis.
reorder_xts is needed to make sure that all lines plots are at the right end of the xts. This is needed for the multibar plot. Because the java script is looping over all series (sets) to determine the width of the bars and we need to make sure we are not looping over the series which are line plots. Otherwise we have additional bars.
multibar_combi_plotter does exactly that. It takes a numeric parameter lines_names and modifies the javascript string so that it loops over all plots except for the line_names (i.e. last series in the right part of the xts). Notice several little %s in the string for the sprintfcommand! Afterwards it returns the plotter as character for the dySeries argument.
All the javascript code is taken directly from the examples in the dygraphs folder.
Here are some examples...
Examples:
dy_position(test,plot_title = "Test1", y2_names = c("Series_C","Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=F)
dy_position(test,plot_title = "Test1", y2_names = c("Series_C","Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=T)
dy_position(test,plot_title = "Test1", y2_names = c("Series_B","Series_C","Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=T)
dy_position(test,plot_title = "Test1", y2_names = c("Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=F)
dy_position(test,plot_title = "Test1", y2_names = c("Series_D"),y1_label = "Axis1", y2_label = "Axis2", stacked=T)
dy_position(test,plot_title = "Test1", y2_names = NULL ,y1_label = "Axis1", y2_label = "Axis2", stacked=F)
dy_position(test,plot_title = "Test1", y2_names = NULL ,y1_label = "Axis1", y2_label = "Axis2", stacked=T)
I am not sure this is exactly what you want. What I propose, comes close to the combination of a bar plot and a line plot, without the need to create a separate function.
You can set the type of plot per series, with dySeries. You can choose between lineplot (default), stepPlot, and stemPlot. In addition you may set to see the points with drawPoints and pointSize, you may also opt to fill the graph or not with fillGraph. For other options type ?dySeries
The code looks as follows:
library(dygraphs)
lungDeaths <- cbind(ldeaths, mdeaths)
dygraph(lungDeaths, main = "Main Title") %>%
dySeries("ldeaths", drawPoints = FALSE) %>%
dySeries("mdeaths", stepPlot = TRUE, fillGraph = TRUE)
Yielding this plot:
Please, let me know whether this is what you want.
After a bit of research I think that this would be simplest. At least that's the way it seems for me.
You would need to download the "barseries.js" file available at http://dygraphs.com/tests/plotters.html
Then the code would look like so
library(dygraphs)
dyBarSeries <- function(dygraph, name, ...) {
file <- "plotters/barseries.js" #you need to link to the downloaded file
plotter_ <- paste0(readLines(file, skipNul = T), collapse = "\n")
dots <- list(...)
do.call('dySeries', c(list(dygraph = dygraph, name = name, plotter =
plotter_), dots))
}
lungDeaths <- cbind(ldeaths, mdeaths)
dygraph(lungDeaths) %>%
dyBarSeries("ldeaths") %>%
dySeries("mdeaths")
Yielding this result
enter image description here

How to set up a "save pic as pdf" button in GUI

1) I used the package gWidget to make a GUI in R. I have had some problems. I want to add a "save" button in the window, but I don't know how to store the pic already drawn in ggraphics.
library("memoise")
library("gWidgets2RGtk2")
library("RGtk2")
library("digest")
library("gWidgets2")
library("stats")
options(guiToolkit="RGtk2")
d<-0
#the main window to make and some parts of it to make
win <- gwindow("Load curve analysis", visible=TRUE,expand = TRUE)
biggroup <- ggroup(horizontal = FALSE, container=win, expand = TRUE)
topgroup<-ggroup(horizontal = TRUE, container=biggroup,expand = TRUE)
bottomgroup<-ggroup(horizontal = TRUE, container=biggroup, expand = TRUE)
leftgroup<-ggroup(horizontal = FALSE, container=bottomgroup,expand= TRUE)
rightgroup<-ggroup(horizontal = FALSE, container=bottomgroup,expand=TRUE)
add(rightgroup, ggraphics(), expand=TRUE)
#draw a pic
updatePlot <- function(h,...) {
if(d==1){
if(svalue(Analyse1)=="Month duration curve")
plot(1:100,1:100,main="1")
if(svalue(Analyse1)=="Month load curve")
plot(1:100,1:100,main="2")
}
if(d==2){
if(svalue(Analyse2)=="Jahresdauerlinie"){
plot(1:100,1:100,main="3")
}
}
}
#the "save" button to make, this button will bring another window,
#but after setting up the road of the saving place, this smaller window will be closed
Store<-gbutton("Save as pdf",container=topgroup, handler = function(h,...){
win1 <- gwindow("set up road", visible=TRUE,expand = TRUE)
group <- ggroup(horizontal = FALSE, container=win1, expand = TRUE)
tmp <- gframe("Pls type the place you want to save in", container=group)
obj0<-gedit("",cont=tmp,expand = TRUE)
tmp <- gframe("Pls name the new diagram, and end it with .pdf", container=group)
obj1<-gedit("Lastganganalyse.pdf",cont=tmp,expand = TRUE)
#here the function recordPlot will be used,but it doesnt work,the document cant be opened
ok<-gbutton("Ok",container=group, handler = function(h,...){
p<-recordPlot()
# I dont know why this record Plot doesnt work
setwd(svalue(obj0))
pdf(svalue(obj1))
p
dev.off()
dispose(win1)
})
})
#the other parts of the main window
tmp <- gframe("Year(after input a year pls press Enter)", container=leftgroup)
#Jahren <- gradio(c(2012,2013,2014), horizontal=FALSE, cont=tmp, handler=updatePlot)
Jahren<-gedit("2012",cont=tmp, handler=updatePlot)
tmp <- gframe("Month", container=leftgroup)
Monat <- gslider(from=1,to=12,by=1, value=1, cont=tmp, handler=updatePlot)
tmp <- gframe("Analysis' way of a month", container=leftgroup)
Analyse1 <- gcombobox(c(" ","Month duration curve","Month load curve"), cont=tmp, handler=function(h,...){
d<<-1
updatePlot(h,...)
},expand = TRUE)
tmp <- gframe("Analysis' way of a year", container=leftgroup)
Analyse2 <- gcombobox(c(" ","Jahresdauerlinie"),cont=tmp,handler=function(h,...){
d<<-2
updatePlot(h,...)},expand = TRUE)
2) Besides, I don't know how to set up the size of the ggroup. Or how can I control all parts of the window's size to look better. I dont know that kind of function.
3) The line which is drawn in ggraphics is hard to be seen. And how can I change this situation?
Suppose we had the following plot in the graphics:
ggplot(dat = data.frame("x" = 1:100, "y" = rnorm(100)), aes(x = x, y = y)) + geom_point()
Within the handler for the button, you can try the following:
setwd(svalue(obj0))
dev.copy2pdf(file = svalue(obj1))

Understanding 'gslider' function to make interactive plots

I am trying to create an interactive histogram in R whose bin width can be adjusted either by moving a slider or entering a value in the text box. In addition to this, I would also like to provide the user with an option of saving the plot for a particular bin width.
To this end, I found the 'gslider' function of 'aplpack' library to be a good starting point. I tried to modify it to meet my purpose as well as learn more about Tcl/Tk constructs. But I am now stuck and can't proceed, mostly because I haven't completely understood how a slider value is captured and transferred between functions.
Following are the snippets of code that I haven't really understood. These are from the source code of the 'gslider' function.
# What is the rationale behind using the 'assign' function here and at
# other instances in the code?
img <- tkrplot::tkrplot(gr.frame, newpl, vscale = 1, hscale = 1)
tkpack(img, side = "top")
assign("img", img, envir = slider.env)
# I understand the below lines when considered individually. But collectively,
# I am having a difficult time comprehending them. Most importantly, where
# exactly is the slider movement captured here?
sc <- tkscale(fr, from = sl.min, to = sl.max,
showvalue = TRUE, resolution = sl.delta, orient = "horiz")
assign("sc", sc, envir = slider.env)
eval(parse(text = "tkconfigure(sc, variable=inputbw1)"), envir = slider.env)
sl.fun <- sl.function
if (!is.function(sl.fun))
sl.fun <- eval(parse(text = paste("function(...){",
sl.fun, "}")))
fname <- 'tkrrsl.fun1'
eval(parse(text = c(paste(fname, " <-"), " function(...){",
"tkrreplot(get('img',envir=slider.env),fun=function()",
deparse(sl.fun)[-1], ")", "}")))
eval(parse(text = paste("environment(", fname, ")<-parent.env")))
if (prompt)
tkconfigure(sc, command = get(fname))
else tkbind(sc, "<ButtonRelease>", get(fname))
if (exists("tkrrsl.fun1")) {
get("tkrrsl.fun1")()
}
assign("slider.values.old", sl.default, envir = slider.env)
Thanks to everyone for the varied scope of answers. Juba's and Greg's answers were the ones I could work upon to write the following code:
slider_txtbox <- function (x, col=1, sl.delta, title)
{
## Validations
require(tkrplot)
pos.of.panel <- 'bottom'
if(is.numeric(col))
col <- names(x)[col]
x <- x[,col, drop=FALSE]
if (missing(x) || is.null(dim(x)))
return("Error: insufficient x values")
sl.min <- sl.delta # Smarter initialization required
sl.max <- max(x)
xrange <- (max(x)-min(x))
sl.default <- xrange/30
if (!exists("slider.env")) {
slider.env <<- new.env(parent = .GlobalEnv)
}
if (missing(title))
title <- "Adjust parameters"
## Creating initial dialogs
require(tcltk)
nt <- tktoplevel()
tkwm.title(nt, title)
if(.Platform$OS.type == 'windows')
tkwm.geometry(nt, "390x490+0+10")
else if(.Platform$OS.type == 'unix')
tkwm.geometry(nt, "480x600+0+10")
assign("tktop.slider", nt, envir = slider.env)
"relax"
nt.bak <- nt
sl.frame <- tkframe(nt)
gr.frame <- tkframe(nt)
tx.frame <- tkframe(nt)
tkpack(sl.frame, tx.frame, gr.frame, side = pos.of.panel)
## Function to create and refresh the plot
library(ggplot2)
library(gridExtra)
makeplot <- function(bwidth, save) {
if(bwidth <= 0) {
df <- data.frame('x'=1:10, 'y'=1:10)
histplot <- ggplot(df, aes(x=x, y=y)) + geom_point(size=0) + xlim(0, 10) + ylim(0, 100) +
geom_text(aes(label='Invalid binwidth...', x=5, y=50), size=9)
} else {
histplot <- ggplot(data=x, aes_string(x=col)) +
geom_histogram(binwidth=bwidth, aes(y = ..density..), fill='skyblue') +
theme(axis.title.x=element_text(size=15), axis.title.y=element_text(size=15),
axis.text.x=element_text(size=10, colour='black'),
axis.text.y=element_text(size=10, colour='black'))
}
print(histplot)
if(save){
filename <- tkgetSaveFile(initialfile=paste('hist_bw_', bwidth, sep=''),
filetypes='{{PNG files} {.png}} {{JPEG files} {.jpg .jpeg}}
{{PDF file} {.pdf}} {{Postscript file} {.ps}}')
filepath <- as.character(filename)
splitpath <- strsplit(filepath, '/')[[1]]
flname <- splitpath[length(splitpath)]
pieces <- strsplit(flname, "\\.")[[1]]
ext <- tolower(pieces[length(pieces)])
if(ext != 'png' && ext != 'jpeg' && ext != 'jpg' && ext != 'pdf' && ext != 'ps') {
ext <- 'png'
filepath <- paste(filepath, '.png', sep='')
filename <- tclVar(filepath)
}
if(ext == 'ps')
ext <- 'postscript'
eval(parse(text=paste(ext, '(file=filepath)', sep='')))
eval(parse(text='print(histplot)'))
dev.off()
}
}
img <- tkrplot::tkrplot(gr.frame, makeplot(sl.default, FALSE), vscale = 1, hscale = 1)
tkpack(img, side = "top")
assign("img", img, envir = slider.env)
## Creating slider, textbox and labels
parent.env <- sys.frame(sys.nframe() - 1)
tkpack(fr <- tkframe(sl.frame), side = 'top')
sc <- tkscale(fr, from = sl.min, to = sl.max,
showvalue = TRUE, resolution = sl.delta,
orient = "horiz")
tb <- tkentry(fr, width=4)
labspace <- tklabel(fr, text='\t\t\t')
tkpack(sc, labspace, tb, side = 'left')
tkpack(textinfo <- tkframe(tx.frame), side = 'top')
lab <- tklabel(textinfo, text = ' Move slider', width = "20")
orlabel <- tklabel(textinfo, text=' OR', width='10')
txtboxmsg <- tklabel(textinfo, text = 'Enter binwidth', width='20')
tkpack(txtboxmsg, orlabel, lab, side='right')
tkpack(f.but <- tkframe(sl.frame))
tkpack(tklabel(f.but, text=''))
tkpack(tkbutton(f.but, text = "Exit", command = function() tkdestroy(nt)),
side='right')
tkpack(tkbutton(f.but, text = "Save", command = function(...) {
bwidth <- as.numeric(tclvalue(get('inputtb', envir=slider.env)))
tkrreplot(get('img',envir=slider.env),fun=function() { makeplot(bwidth, TRUE); sync_slider()})
}), side='right')
## Creating objects and variables associated with slider and textbox
assign("sc", sc, envir = slider.env)
eval(parse(text = "assign('inputsc', tclVar(sl.default), envir=slider.env)"))
eval(parse(text = "tkconfigure(sc, variable=inputsc)"), envir = slider.env)
assign("tb", tb, envir = slider.env)
eval(parse(text = "assign('inputtb', as.character(tclVar(sl.default)),
envir=slider.env)"))
eval(parse(text = "tkconfigure(tb, textvariable=inputtb)"), envir = slider.env)
## Function to update the textbox value when the slider has changed
sync_textbox <- function() {
bwidth_sl <- tclvalue(get('inputsc', envir=slider.env))
assign('inputtb', tclVar(bwidth_sl), envir=slider.env)
eval(parse(text = "tkconfigure(tb, textvariable=inputtb)"), envir = slider.env)
}
## Function to update the slider value when the textbox has changed
sync_slider <- function() {
bwidth_tb <- tclvalue(get('inputtb', envir=slider.env))
assign('inputsc', tclVar(bwidth_tb), envir=slider.env)
eval(parse(text = "tkconfigure(sc, variable=inputsc)"), envir = slider.env)
}
## Bindings : association of certain functions to certain events for the slider
## and the textbox
tkbind(sc, "<ButtonRelease>", function(...) {
bwidth <- as.numeric(tclvalue(get('inputsc', envir=slider.env)))
tkrreplot(get('img',envir=slider.env),fun=function() { makeplot(bwidth, FALSE); sync_textbox()})
})
tkbind(tb, "<Return>", function(...) {
bwidth <- as.numeric(tclvalue(get('inputtb', envir=slider.env)))
if(bwidth > sl.max && !is.na(bwidth)) {
bwidth <- sl.max
assign('inputtb', tclVar(bwidth), envir=slider.env)
eval(parse(text = "tkconfigure(tb, textvariable=inputtb)"), envir = slider.env)
} else
if(bwidth < sl.min || is.na(bwidth)) {
bwidth <- sl.min
assign('inputtb', tclVar(bwidth), envir=slider.env)
eval(parse(text = "tkconfigure(tb, textvariable=inputtb)"), envir = slider.env)
}
tkrreplot(get('img',envir=slider.env),fun=function() { makeplot(bwidth, FALSE); sync_slider()})
})
}
library(ggplot2)
slider_txtbox(movies, 'rating', 0.1, 'Adjust binwidth')
Here is a minimal working example with comments, based on the complete code you first submit. As I'm far from an expert in tcl/tk, there may be cleaner or better ways to do it. And it is quite incomplete (for example the textbox values should be checked to be in the range of the slider, etc.) :
library(ggplot2)
library(gridExtra)
title <- "Default title"
data(movies)
## Init dialog
require(tkrplot)
if (!exists("slider.env")) slider.env <<- new.env(parent = .GlobalEnv)
require(tcltk)
nt <- tktoplevel()
tkwm.title(nt, title)
tkwm.geometry(nt, "480x600+0+10")
assign("tktop.slider", nt, envir = slider.env)
"relax"
nt.bak <- nt
sl.frame <- tkframe(nt)
gr.frame <- tkframe(nt)
tx.frame <- tkframe(nt)
tkpack(sl.frame, tx.frame, gr.frame, side = "bottom")
## First default plot
newpl <- function(...) {
dummydf <- data.frame('x'=1:10, 'y'=1:10)
dummy <- ggplot(dummydf, aes(x=x, y=y)) + geom_point(size=0) + xlim(0, 10) + ylim(0, 100) +
geom_text(aes(label='Generating plot...', x=5, y=50), size=9)
print(dummy)
}
img <- tkrplot::tkrplot(gr.frame, newpl, vscale = 1, hscale = 1)
tkpack(img, side = "top")
assign("img", img, envir = slider.env)
tkpack(fr <- tkframe(sl.frame), side = 'top')
## Creating slider, textbox and labels
sc <- tkscale(fr, from = 0, to = 5, showvalue = TRUE, resolution = 0.1, orient = "horiz")
tb <- tkentry(fr, width=4)
lab <- tklabel(fr, text = 'Select binwidth ', width = "16")
orlabel <- tklabel(fr, text=' or ', width='4')
tkpack(lab, sc, orlabel, tb, side = 'left')
tkpack(textinfo <- tkframe(tx.frame), side = 'top')
## Creating objects and variables associated with slider and textbox
assign("sc", sc, envir = slider.env)
assign("tb", tb, envir = slider.env)
assign('inputsc', tclVar(2.5), envir=slider.env)
assign('inputtb', tclVar('2.5'), envir=slider.env)
eval(parse(text = "tkconfigure(sc, variable=inputsc)"), envir = slider.env)
eval(parse(text = "tkconfigure(tb, textvariable=inputtb)"), envir = slider.env)
## Function to update the textbox value when the slider has changed
sync_textbox <- function() {
bwidth_sl <- tclvalue(get('inputsc', envir=slider.env))
assign('inputtb', tclVar(bwidth_sl), envir=slider.env)
eval(parse(text = "tkconfigure(tb, textvariable=inputtb)"), envir = slider.env)
}
## Function to update the slider value when the textbox has changed
sync_slider <- function() {
bwidth_tb <- tclvalue(get('inputtb', envir=slider.env))
assign('inputsc', tclVar(bwidth_tb), envir=slider.env)
eval(parse(text = "tkconfigure(sc, variable=inputsc)"), envir = slider.env)
}
## Function to refresh the plot
refresh <- function(bwidth) {
histplot <- ggplot(data=movies, aes_string(x="rating")) +
geom_histogram(binwidth=bwidth,
aes(y = ..density..), fill='skyblue') +
theme(axis.title.x=element_text(size=15), axis.title.y=element_text(size=15),
axis.text.x=element_text(size=10, colour='black'),
axis.text.y=element_text(size=10, colour='black'))
print(histplot)
}
## Bindings : association of certain functions to certain events for the slider
## and the textbox
tkbind(sc, "<ButtonRelease>", function(...) {
bwidth <- as.numeric(tclvalue(get('inputsc', envir=slider.env)))
tkrreplot(get('img',envir=slider.env),fun=function() { refresh(bwidth); sync_textbox()})
})
tkbind(tb, "<Return>", function(...) {
bwidth <- as.numeric(tclvalue(get('inputtb', envir=slider.env)))
tkrreplot(get('img',envir=slider.env),fun=function() { refresh(bwidth); sync_slider()})
})
If you do not insist on a local solution, you might give rapporter.net a try, which lets you specify such tasks easily with any number of tweakable sliders. Okay, enough of marketing :)
Here goes a quick demo: Interactive histogram on mtcars which looks like:
There you could choose one of the well-know variables of mtcars, but of course you could provide any data frame to be used here or tweak the above form after a free registration.
How it's done? I have just created a quick rapport template and let it rapplicate. The body of the template is written in brew-style (please see the above "rapport" URL for more details):
<%=
evalsOptions('width', width)
evalsOptions('height', height)
%>
# Histogram
<%=
set.caption(paste('Histogram of', var.name))
hist(var, breaks=seq(min(var), max(var), diff(range(var))/round(binwidth)), main = paste('Histogram of', var.name), xlab = '')
%>
## Parameters
Provided parameters were:
* variable: <%=var.name%> (<%=var.label%>)
* bin-width of histogram: <%=binwidth%>
* height of generated images: <%=height%>
* width of generated images: <%=width%>
# Kernel density plot
<%=
set.caption('A kernel density plot')
plot(density(var), main = '', xlab = '')
%>
But a bare-minimal example of the task could be also addressed by a simple one-liner template:
<%=hist(var, breaks=seq(min(var), max(var), diff(range(var))/round(binwidth)))%>
There you would only need to create a new template, add two input types with a click (one numeric variable of any data set and a number input field which would hold the binwidth of the histogram), and you are ready to go.
You might want to look at the R package 'rpanel' -- it uses tcltk under the hood but is much simpler to use:
rpanel
rpanel reference
I don't know the gslider function and cannot help you there, but here are some alternatives:
One simple option is to use the tkexamp function from the TeachingDemos package, here is one way:
library(TeachingDemos)
myhist <- function(x, s.width, e.width, ...) {
if( missing(e.width) || is.null(e.width) || is.na(e.width) ) {
e.width<- s.width
}
b <- seq( min(x)-e.width/2, max(x)+e.width, by=e.width )
hist(x, b, ...)
}
mylist <- list( s.width=list('slider', init=1, from=1, to=10, resolution=1),
e.width=list('numentry', init='', width=7)
)
sampdata <- rnorm(100, 50, 5)
tkexamp(myhist(sampdata), mylist)
This will create a quick GUI with your histogram and a slider and entry widget. The width of the bars are determined by the value in the entry widget, and if that is blank (default) then the value of the slider. Unfortunately the slider and entry widget do not update each other. There is a button that will print out the current call, so the same plot can be recreated from the command line in the default or current plotting device. You can edit the mylist variable above to make the controls fit your data better.
If you want the entry and slider to update each other then you can program that more directly. Here is a basic function that uses tkrplot:
mytkhist <- function(x, ...) {
width <- tclVar()
tclvalue(width) <- 1
replot <- function(...) {
width <- as.numeric(tclvalue(width))
b <- seq( min(x) - width/2, max(x)+width, by=width )
hist(x,b,...)
}
tt <- tktoplevel()
img <- tkrplot(tt, replot)
tkpack(img, side='top')
tkpack( tkscale(tt, variable=width, from=1, to=10,
command=function(...) tkrreplot(img),
orient='horizontal'), side='top' )
tkpack( e <- tkentry(tt, textvariable=width), side='top' )
tkbind(e, "<KeyRelease>", function(...) tkrreplot(img))
}
mytkhist(sampdata)
The fact that both the slider (scale) and the entry widget use the same variable is what makes them automatically update each other (no calls to assign needed). The command argument in tkscale and the tkbind call mean that any changes to either the slider or the entry will update the plot. This does not have anything to save the current plot, but you should be able to add that part as well as any other controls that you want to use.

Resources