Related
I am trying to modify an existing function by copy and pasting it to an R script, and assigning it to a new function object in my local environment. However the new function cannot find functions that are called to within the original function. How can I fix this without looking up and finding each function individually? I am guessing that the original function is somehow linked to the package or its dependencies and 'knows where to look' for the missing function, but I cannot figure out how to do this with my new copy-and-pasted function.
library("camtrapR")
Print the function name
activityDensity
The output here is the code for this function. I have omitted it here because it is long (and I have pasted it below), but I copy and paste the output of the function code exactly (see below where I assign this exact code to a new function), except for the last two lines of output, which I think are important:
<bytecode: 0x000000002a2d1e20>
<environment: namespace:camtrapR>
So now I assign the copy and pasted code from the output above to a new function with New <-
New <- function (recordTable, species, allSpecies = FALSE, speciesCol = "Species",
recordDateTimeCol = "DateTimeOriginal", recordDateTimeFormat = "%Y-%m-%d %H:%M:%S",
plotR = TRUE, writePNG = FALSE, plotDirectory, createDir = FALSE,
pngMaxPix = 1000, add.rug = TRUE, ...)
{
wd0 <- getwd()
mar0 <- par()$mar
on.exit(setwd(wd0))
on.exit(par(mar = mar0), add = TRUE)
recordTable <- dataFrameTibbleCheck(df = recordTable)
timeZone <- "UTC"
checkForSpacesInColumnNames(speciesCol = speciesCol, recordDateTimeCol = recordDateTimeCol)
if (!is.data.frame(recordTable))
stop("recordTable must be a data frame", call. = FALSE)
if (!speciesCol %in% colnames(recordTable))
stop(paste("speciesCol = \"", speciesCol, "\" is not a column name in recordTable",
sep = ""), call. = FALSE)
if (!recordDateTimeCol %in% colnames(recordTable))
stop(paste("recordDateTimeCol = \"", recordDateTimeCol,
"\" is not a column name in recordTable", sep = ""),
call. = FALSE)
stopifnot(is.logical(c(allSpecies, writePNG, plotR, createDir)))
if (allSpecies == FALSE) {
stopifnot(species %in% recordTable[, speciesCol])
stopifnot(hasArg(species))
}
recordTable$DateTime2 <- parseDateTimeObject(inputColumn = recordTable[,
recordDateTimeCol], dateTimeFormat = recordDateTimeFormat,
timeZone = timeZone)
recordTable$Time2 <- format(recordTable$DateTime2, format = "%H:%M:%S",
usetz = FALSE)
recordTable$Time.rad <- (as.numeric(as.POSIXct(strptime(recordTable$Time2,
format = "%H:%M:%S", tz = timeZone))) - as.numeric(as.POSIXct(strptime("0",
format = "%S", tz = timeZone))))/3600 * (pi/12)
if (isTRUE(writePNG)) {
if (hasArg(plotDirectory)) {
if (isTRUE(createDir)) {
dir.create(plotDirectory, recursive = TRUE, showWarnings = FALSE)
setwd(plotDirectory)
}
else {
stopifnot(file.exists(plotDirectory))
setwd(plotDirectory)
}
}
else {
stop("writePNG is TRUE. Please set plotDirectory",
call. = FALSE)
}
}
pngWidth <- pngMaxPix
pngHeight <- round(pngMaxPix * 0.8)
if (allSpecies == FALSE) {
subset_species <- subset(recordTable, recordTable[, speciesCol] ==
species)
if (nrow(subset_species) == 1)
stop(paste(species, "had only 1 record. Cannot estimate density."),
call. = FALSE)
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
species, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = paste("Activity of",
species), rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(species), ": ", try_error_tmp[1],
" - SKIPPED", sep = ""), call. = FALSE)
}
else {
subset_species_list <- list()
for (i in 1:length(unique(recordTable[, speciesCol]))) {
spec.tmp <- unique(recordTable[, speciesCol])[i]
subset_species <- subset(recordTable, recordTable[,
speciesCol] == spec.tmp)
plot_main_title <- paste("Activity of", spec.tmp)
if (nrow(subset_species) == 1) {
warning(paste(toupper(spec.tmp), ": It had only 1 record. Cannot estimate density. - SKIPPED",
sep = ""), call. = FALSE)
next
}
else {
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
spec.tmp, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = plot_main_title,
rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(spec.tmp), ": ",
try_error_tmp[1], " - SKIPPED",
sep = ""), call. = FALSE)
}
subset_species_list[[i]] <- subset_species$Time.rad
names(subset_species_list)[i] <- spec.tmp
}
}
if (allSpecies == FALSE) {
return(invisible(subset_species$Time.rad))
}
else {
return(invisible(subset_species_list))
}
}
Yet, when I try to run this new function (arguments omitted here for clarity), it can't find a function embedded within.
How can I somehow assign this function to look within the original package camtrapR for any dependencies, etc.? and why does the code output from the function not already do this?
New()
Error in dataFrameTibbleCheck(df = recordTable) :
could not find function "dataFrameTibbleCheck"
This answer here: https://stackoverflow.com/a/49277036/9096420 allows one to manually edit and save a function's code for each R session, but it is non-reproducible (not code) that can be shared or re-used.
If New is the new function copied from camtrapR then use
environment(New) <- asNamespace("camtrapR")
to ensure that the function calls in its body are looked up in the correct places.
I am using RSSA package in R and I need to access the eigenvalues.
using the following code I can plot the components. However, I need to access all eigenvalues as numbers.
require(Rssa)
t=ssa(co2)
plot(t)
I know almost nothing about this package. I'm taking from context that you want the values that are plotted on the y-axis of that graphic. Lacking a reproducible example, I turn to the ?ssa help page and use the first example:
> s <- ssa(co2)
>
> plot(s)
So that looks like your plot: Then I look at the code
> getAnywhere(plot.ssa)
A single object matching ‘plot.ssa’ was found
It was found in the following places
registered S3 method for plot from namespace Rssa
namespace:Rssa
with value
function (x, type = c("values", "vectors", "paired", "series",
"wcor"), ..., vectors = c("eigen", "factor"), plot.contrib = TRUE,
numvalues = nsigma(x), numvectors = min(nsigma(x), 10), idx = 1:numvectors,
idy, groups)
{
type <- match.arg(type)
vectors <- match.arg(vectors)
if (identical(type, "values")) {
.plot.ssa.values(x, ..., numvalues = numvalues)
}
else if (identical(type, "vectors")) {
.plot.ssa.vectors(x, ..., what = vectors, plot.contrib = plot.contrib,
idx = idx)
}
else if (identical(type, "paired")) {
if (missing(idy))
idy <- idx + 1
.plot.ssa.paired(x, ..., what = vectors, plot.contrib = plot.contrib,
idx = idx, idy = idy)
}
else if (identical(type, "series")) {
if (missing(groups))
groups <- as.list(1:min(nsigma(x), nu(x)))
.plot.ssa.series(x, ..., groups = groups)
}
else if (identical(type, "wcor")) {
if (missing(groups))
groups <- as.list(1:min(nsigma(x), nu(x)))
plot(wcor(x, groups = groups), ...)
}
else {
stop("Unsupported type of SSA plot!")
}
}
<environment: namespace:Rssa>
So then I look at the function called when the default arguments are used:
> getAnywhere(.plot.ssa.values)
A single object matching ‘.plot.ssa.values’ was found
It was found in the following places
namespace:Rssa
with value
function (x, ..., numvalues, plot.type = "b")
{
dots <- list(...)
d <- data.frame(A = 1:numvalues, B = x$sigma[1:numvalues])
dots <- .defaults(dots, type = plot.type, xlab = "Index",
ylab = "norms", main = "Component norms", grid = TRUE,
scales = list(y = list(log = TRUE)), par.settings = list(plot.symbol = list(pch = 20)))
do.call("xyplot", c(list(x = B ~ A, data = d, ssaobj = x),
dots))
}
<environment: namespace:Rssa>
So the answer appears to be:
s$sigma
[1] 78886.190749 329.031810 327.198387 184.659743 88.695271 88.191805
[7] 52.380502 40.527875 31.329930 29.409384 27.157698 22.334446
[13] 17.237926 14.175096 14.111402 12.976716 12.943775 12.216524
[19] 11.830642 11.614243 11.226010 10.457529 10.435998 9.774000
[25] 9.710220 9.046872 8.995923 8.928725 8.809155 8.548962
[31] 8.358872 7.699094 7.266915 7.243014 7.164837 6.203210
[37] 6.085105 6.064150 6.035110 6.028446 5.845783 5.808865
[43] 5.770708 5.753422 5.680897 5.672330 5.650324 5.612606
[49] 5.599314 5.572931
Below I've constructed an Upset plot. I'm using a palette of colors to define the bar colors. Is there a way to do this for the matrix of connected dots as well?
library(dplyr)
library(RColorBrewer)
library(UpSetR)
movies <- read.csv(system.file("extdata", "movies.csv",
package = "UpSetR"), header=T, sep=";" )
movies <- select(movies, Action:Children)
upset(movies, main.bar.color=brewer.pal(2^ncol(movies)-1, "Set1"))
When attempting to apply the palette to the matrix, I get warnings and only the first color, red, is used.
upset(movies, main.bar.color=brewer.pal(2^ncol(movies)-1, "Set1"),
matrix.color=brewer.pal(2^ncol(movies)-1, "Set1"))
upset allows to specify only one color for matrix.color.
A solution is to modify the UpSetR:::Create_layout function:
Create_layout <- function (setup, mat_color, mat_col, matrix_dot_alpha)
{
Matrix_layout <- expand.grid(y = seq(nrow(setup)), x = seq(ncol(setup)))
Matrix_layout <- data.frame(Matrix_layout, value = as.vector(setup))
for (i in 1:nrow(Matrix_layout)) {
if (Matrix_layout$value[i] > as.integer(0)) {
# Here I propose to change Matrix_layout$color[i] <- mat_color with
# Matrix_layout$color[i] <- mat_color[i]
Matrix_layout$color[i] <- mat_color[i]
Matrix_layout$alpha[i] <- 1
Matrix_layout$Intersection[i] <- paste(Matrix_layout$x[i],
"yes", sep = "")
}
else {
Matrix_layout$color[i] <- "gray83"
Matrix_layout$alpha[i] <- matrix_dot_alpha
Matrix_layout$Intersection[i] <- paste(i, "No", sep = "")
}
}
if (is.null(mat_col) == F) {
for (i in 1:nrow(mat_col)) {
mat_x <- mat_col$x[i]
mat_color <- as.character(mat_col$color[i])
for (i in 1:nrow(Matrix_layout)) {
if ((Matrix_layout$x[i] == mat_x) && (Matrix_layout$value[i] !=
0)) {
Matrix_layout$color[i] <- mat_color
}
}
}
}
return(Matrix_layout)
}
# Replace Create_layout in UpSetR with the modified function
assignInNamespace(x="Create_layout", value=Create_layout, ns="UpSetR")
# Now you can set colors for the matrix of connected dots
# The dimension of this matrix is 3 x 7
upset(movies, main.bar.color=brewer.pal(2^ncol(movies)-1, "Set1"),
matrix.color=rainbow(21))
I am using the package networkDynamic to visualise two evolving networks and I would like to add, close to each network a simple legend (a few words of text). I can't find a way of doing this.
In the networkDynamic package, the function render.animation uses plot.network (from the package network) to render each frame and then compiles the different frames into an animation.
The plot.network arguments can be passed to render.animation, so the problem seems to boils down to adding text to a plot generated with plot.network but there doesn't seem to be a way of adding text at specified coordinates.
With a normal plot I would use the text function, but is there a way of including this function into the plot.network arguments?
render.animation is a function in the ndtv package. You will have to create a custom render.animation2 function based on render.animation. In the following function, I add an extra line to the render.animation function. I add an mtext after each plot.network calls (see about 20 lines from the end). You could change it to a text instead of mtext.
render.animation2 <- function (net, render.par = list(tween.frames = 10, show.time = TRUE,
show.stats = NULL, extraPlotCmds = NULL, initial.coords = 0),
plot.par = list(bg = "white"), ani.options = list(interval = 0.1),
render.cache = c("plot.list", "none"), verbose = TRUE, ...)
{
if (!is.network(net)) {
stop("render.animation requires the first argument to be a network object")
}
if (is.null(render.par)) {
stop("render.animation is missing the 'render.par' argument (a list of rendering parameters).")
}
if (is.null(render.par$tween.frames)) {
render.par$tween.frames <- 10
}
if (is.null(render.par$show.time)) {
render.par$show.time <- TRUE
}
if (is.null(render.par$initial.coords)) {
render.par$initial.coords <- matrix(0, ncol = 2, nrow = network.size(net))
}
if (!all(c("animation.x.active", "animation.y.active") %in%
list.vertex.attributes(net))) {
net <- compute.animation(net, verbose = verbose)
}
externalDevice <- FALSE
doRStudioHack <- TRUE
if (!is.null(render.par$do_RStudio_plot_hack)) {
doRStudioHack <- render.par$do_RStudio_plot_hack
}
if (!is.function(options()$device)) {
if (names(dev.cur()) == "RStudioGD" & doRStudioHack) {
message("RStudio's graphics device is not well supported by ndtv, attempting to open another type of plot window")
if (.Platform$OS.type == "windows") {
windows()
}
else if (length(grep(R.version$platform, pattern = "apple")) >
0) {
quartz()
}
else {
x11()
}
externalDevice <- TRUE
}
}
if (par("bg") == "transparent" & is.null(plot.par$bg)) {
plot.par$bg <- "white"
}
origPar <- par(plot.par)
oopts <- ani.options(ani.options)
slice.par <- get.network.attribute(net, "slice.par")
if (is.null(slice.par)) {
stop("render.animation can not locate the 'slice.par' list of parameters in the input network object")
}
render.cache <- match.arg(render.cache)
plot_params <- list(...)
if (is.null(plot_params$label)) {
plot_params$label <- function(slice) {
network.vertex.names(slice)
}
}
if (is.null(plot_params$xlab) & render.par$show.time) {
plot_params$xlab <- function(onset, terminus) {
ifelse(onset == terminus, paste("t=", onset, sep = ""),
paste("t=", onset, "-", terminus, sep = ""))
}
}
if (!is.null(render.par$show.stats) && render.par$show.stats !=
FALSE) {
if (render.par$show.time) {
plot_params$xlab <- eval(parse(text = paste("function(slice,onset,terminus){stats<-summary.statistics.network(slice",
render.par$show.stats, ")\n return(paste('t=',onset,'-',terminus,' ',paste(rbind(names(stats),stats),collapse=':'),sep='')) }",
sep = "")))
}
else {
plot_params$xlab <- eval(parse(text = paste("function(slice){stats<-summary.statistics.network(slice",
render.par$show.stats, ")\n return(paste(rbind(names(stats),stats),collapse=':')) }",
sep = "")))
}
}
if (is.null(plot_params$jitter)) {
plot_params$jitter <- FALSE
}
interp.fun <- coord.interp.smoothstep
starts <- seq(from = slice.par$start, to = slice.par$end,
by = slice.par$interval)
ends <- seq(from = slice.par$start + slice.par$aggregate.dur,
to = slice.par$end + slice.par$aggregate.dur, by = slice.par$interval)
xmin <- aggregate.vertex.attribute.active(net, "animation.x",
min)
xmax <- aggregate.vertex.attribute.active(net, "animation.x",
max)
ymin <- aggregate.vertex.attribute.active(net, "animation.y",
min)
ymax <- aggregate.vertex.attribute.active(net, "animation.y",
max)
if (is.null(plot_params$xlim)) {
if (xmin == xmax) {
xmax <- xmin + 1
xmin <- xmin - 1
}
plot_params$xlim <- c(xmin, xmax)
}
if (is.null(plot_params$ylim)) {
if (ymin == ymax) {
ymax <- ymin + 1
ymin <- ymin - 1
}
plot_params$ylim <- c(ymin, ymax)
}
if (is.numeric(render.par$initial.coords)) {
coords <- matrix(render.par$initial.coords, ncol = 2,
nrow = network.size(net))
}
slice <- network.collapse(net, starts[1], ends[1], rule = slice.par$rule,
rm.time.info = FALSE)
activev <- is.active(net, starts[1], ends[1], v = seq_len(network.size(net)),
rule = if (slice.par$rule != "all") {
"any"
})
if (length(slice) > 0 & network.size(slice) > 0) {
coords[activev, 1] <- get.vertex.attribute(slice, "animation.x")
coords[activev, 2] <- get.vertex.attribute(slice, "animation.y")
}
coords2 <- coords
if (render.cache == "plot.list") {
ani.record(reset = TRUE)
}
for (s in 1:length(starts)) {
if (verbose) {
print(paste("rendering", render.par$tween.frames,
"frames for slice", s - 1))
}
slice <- network.collapse(net, starts[s], ends[s], rule = slice.par$rule,
rm.time.info = FALSE)
activev <- is.active(net, starts[s], ends[s], v = seq_len(network.size(net)),
rule = if (slice.par$rule != "all") {
"any"
})
if (length(slice) > 0 & network.size(slice) > 0) {
evald_params <- .evaluate_plot_params(plot_params = plot_params,
net = net, slice = slice, s = s, onset = starts[s],
terminus = ends[s])
for (t in 1:render.par$tween.frames) {
coords2[activev, 1] <- get.vertex.attribute(slice,
"animation.x")
coords2[activev, 2] <- get.vertex.attribute(slice,
"animation.y")
tweenCoords <- interp.fun(coords, coords2, t,
render.par$tween.frames)
plot_args <- list(x = slice, coord = tweenCoords[activev,
, drop = FALSE])
plot_args <- c(plot_args, evald_params)
do.call(plot.network, plot_args)
mtext("my text\n on two lines", side = 3) #my.legend
if (!is.null(render.par$extraPlotCmds)) {
eval(render.par$extraPlotCmds)
}
if (render.cache == "plot.list") {
ani.record()
}
}
coords <- coords2
}
else {
evald_params <- .evaluate_plot_params(plot_params = plot_params,
net = net, slice = slice, s = s, onset = starts[s],
terminus = ends[s])
if (render.par$show.time) {
xlab <- evald_params$xlab
}
else {
xlab <- NULL
}
singlenet <- network.initialize(1)
for (t in 1:render.par$tween.frames) {
plot.network(singlenet, vertex.cex = 0, xlab = xlab)
if (!is.null(render.par$extraPlotCmds)) {
eval(render.par$extraPlotCmds)
}
if (render.cache == "plot.list") {
ani.record()
}
}
}
}
par(origPar)
if (externalDevice) {
dev.off()
}
}
It is then important to assign your new function render.animation2 to the ndtv namespace. If you don't, it will crash because render.animation refers to functions that can only be found in its own namespace.
environment(render.animation2) <- asNamespace('ndtv')
environment(render.animation) #<environment: namespace:ndtv>
environment(render.animation2) #<environment: namespace:ndtv>
Using, render.animation2, you will then get your legend printed on each slide of the animation.
require(ndtv)
triangle <- network.initialize(3) # create a toy network
add.edge(triangle,1,2)
# add an edge between vertices 1 and 2
add.edge(triangle,2,3)
# add a more edges
activate.edges(triangle,at=1) # turn on all edges at time 1 only
activate.edges(triangle,onset=2, terminus=3,
e=get.edgeIDs(triangle,v=1,alter=2))
add.edges.active(triangle,onset=4, length=2,tail=3,head=1)
render.animation2(triangle) #custom function
ani.replay()
Here's what the last slide looks like in the animation:
If you only need to add a few lines of text, you can pass the standard plot arguments main (for the main title) or xlab (for the x-axis caption). you can separate lines with the newline escape "\n"
library(ndtv)
data(short.stergm.sim)
render.animation(short.stergm.sim,main='hello\nworld')
It is also possible to plot other graphic elements (such as legend or text or maps) using the extraPlotCmds argument to render.animation. For example, if you wanted to plot "hello world" in blue at coordiantes 0,0 using text you can wrap it in an expression and pass it in via render.par
render.animation(short.stergm.sim,
render.par=list(extraPlotCmds=expression(
text(0,0,'hello\nworld',col='blue')
))
)
the extra plot command will evaluated on each frame as the network is rendered
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.