Related
This a reprex.
dt <- data.frame(a = 1:3, b = c("a", "b", ""))
dt$sup <- paste0(dt$a, "_[", dt$b, "]") # create superscript col, enclosed in '_[]'
wb <- openxlsx::createWorkbook() # create workbook
openxlsx::addWorksheet(wb, sheetName = "data") # add sheet
openxlsx::writeData(wb, sheet=1, x=dt, xy=c(1, 1)) # write data on workbook
for(i in grep("\\_\\[([A-z0-9\\s]*)\\]", wb$sharedStrings)){
# if empty string in superscript notation, then just remove the superscript notation
if(grepl("\\_\\[\\]", wb$sharedStrings[[i]])){
wb$sharedStrings[[i]] <- gsub("\\_\\[\\]", "", wb$sharedStrings[[i]])
next # skip to next iteration
}
# insert additioanl formating in shared string
wb$sharedStrings[[i]] <- gsub("<si>", "<si><r>", gsub("</si>", "</r></si>", wb$sharedStrings[[i]]))
# find the "_[...]" pattern, remove brackets and udnerline and enclose the text with superscript format
wb$sharedStrings[[i]] <- gsub("\\_\\[([A-z0-9\\s]*)\\]", "</t></r><r><rPr><vertAlign val=\"superscript\"/></rPr><t xml:space=\"preserve\">\\1</t></r><r><t xml:space=\"preserve\">", wb$sharedStrings[[i]])
}
openxlsx::saveWorkbook(wb, file="test.xlsx", overwrite = TRUE)
This is a the output from the code above:
I need to change some part of the xml code to generate bold text as this:
I tried using the formating from openxlsx package but I get:
This is the code from openxlsx formating, but it does not bold the superscript part as you see above. So I think the path for doing that is modifying the xml code in order to get it, and that's the help I need.
openxlsx::addStyle(wb, "text.xlsx",
style = openxlsx::createStyle(textDecoration = "bold"),
rows = 2:3, cols = 3, gridExpand = TRUE)
I solve this with this function with only one input:
your input texto should be in this format:
text: "normal text [superscript] ~ subscript ~" (avoid spaces between ~)
addSuperSubScriptToCell_general <- function(wb,
sheet,
row,
col,
texto,
size = '10',
colour = '000000',
font = 'Arial',
family = '2',
bold = FALSE,
italic = FALSE,
underlined = FALSE) {
placeholderText <- 'This is placeholder text that should not appear anywhere in your document.'
openxlsx::writeData(wb = wb,
sheet = sheet,
x = placeholderText,
startRow = row,
startCol = col)
#finds the string that you want to update
stringToUpdate <- which(sapply(wb$sharedStrings,
function(x){
grep(pattern = placeholderText,
x)
}
)
== 1)
#splits the text into normal text, superscript and subcript
normal_text <- str_split(texto, "\\[.*\\]|~.*~") %>% pluck(1) %>% purrr::discard(~ . == "")
sub_sup_text <- str_extract_all(texto, "\\[.*\\]|~.*~") %>% pluck(1)
if (length(normal_text) > length(sub_sup_text)) {
sub_sup_text <- c(sub_sup_text, "")
} else if (length(sub_sup_text) > length(normal_text)) {
normal_text <- c(normal_text, "")
}
# this is the separated text which will be used next
texto_separado <- map2(normal_text, sub_sup_text, ~ c(.x, .y)) %>%
reduce(c) %>%
purrr::discard(~ . == "")
#formatting instructions
sz <- paste('<sz val =\"',size,'\"/>',
sep = '')
col <- paste('<color rgb =\"',colour,'\"/>',
sep = '')
rFont <- paste('<rFont val =\"',font,'\"/>',
sep = '')
fam <- paste('<family val =\"',family,'\"/>',
sep = '')
#if its sub or sup adds the corresponding xml code
sub_sup_no <- function(texto) {
if(str_detect(texto, "\\[.*\\]")){
return('<vertAlign val=\"superscript\"/>')
} else if (str_detect(texto, "~.*~")) {
return('<vertAlign val=\"subscript\"/>')
} else {
return('')
}
}
#get text from normal text, sub and sup
get_text_sub_sup <- function(texto) {
str_remove_all(texto, "\\[|\\]|~")
}
#formating
if(bold){
bld <- '<b/>'
} else{bld <- ''}
if(italic){
itl <- '<i/>'
} else{itl <- ''}
if(underlined){
uld <- '<u/>'
} else{uld <- ''}
#get all properties from one element of texto_separado
get_all_properties <- function(texto) {
paste0('<r><rPr>',
sub_sup_no(texto),
sz,
col,
rFont,
fam,
bld,
itl,
uld,
'</rPr><t xml:space="preserve">',
get_text_sub_sup(texto),
'</t></r>')
}
# use above function in texto_separado
newString <- map(texto_separado, ~ get_all_properties(.)) %>%
reduce(paste, sep = "") %>%
{c("<si>", ., "</si>")} %>%
reduce(paste, sep = "")
# replace initial text
wb$sharedStrings[stringToUpdate] <- newString
}
I need help to barplot multiple files in a loop. I have created a function to barplot these different files for only two columns out of 5 columns input file contains and then call the function
bar.plot <- function( col_name1, col_name2,input_file, lable1, lable2) {
barplot(col_name1, names.arg = col_name2, xlab = "label1", ylab = "lable2",
col= "blue", main = "bar plot of average", border = "red")
box()
}
#call the function for 10 files
i <- 1
for (i in 1:10) {
filename <- paste("C:/Users/admin/GoogleDrive/Vidya/R/document/Group_",
i, ".csv", sep = "")
group <- read.csv(filename)
lablex <- "average"
labley <- "master id"
bar.plot(group$total_pause_time, group$employee_id, group, lablex, labley)
}
output plot shows xlable as label1 and ylable as label2, even though I have entered "average" in lablex and "master id" in labley.
Also tell me how to save these different plots with 10 diffrent names e.g. plot1.jpg to plot10.jpg
This will create a pdf file of your ten individual plots
bar.plot <- function( col_name1, col_name2,input_file, lable1, lable2)
{
barplot(col_name1,names.arg = col_name2,xlab=label1,ylab=label2,
col= "blue",main = "bar plot of average",border = "red")
box()
}
#call the function for 10 files
label1 <- "average"
label2 <- "master id"
setwd("C:/Users/admin/GoogleDrive/Vidya/R/document/Group_/")
filename <- list.files(pattern = ".csv")
myfiles <- lapply(filename, read.csv)
for (i in myfiles)
{
group <- data.frame(myfiles[i])
jpeg(paste(i,".jpg"))
bar.plot(group$total_pause_time,group$employee_id,label1,label2)
dev.off()
}
Try this:
bar.plot <- function( col_name1, col_name2,input_file, lable1, lable2) {
barplot(col_name1,names.arg = col_name2, xlab = lable1, ylab = lable2,
col= "blue",main = "bar plot of average",border = "red")
box()
}
#call the function for 10 files
for (i in 1:10){
filename <-paste("C:/Users/admin/GoogleDrive/Vidya/R/document/Group_",i,".csv",sep = "")
group <- read.csv(filename)
lable1 <- "average"
lable2 <- "master id"
bar.plot(group$total_pause_time,group$employee_id, group, lable1, lable2)
dev.copy(jpg,paste("C:/Users/admin/GoogleDrive/Vidya/R/document/plot",i,".jpg)
dev.off()
}
I have made a loop for making multiply plots, however i have no way of saving them, my code looks like this:
#----------------------------------------------------------------------------------------#
# RING data: Mikkel
#----------------------------------------------------------------------------------------#
# Set working directory
setwd()
#### Read data & Converting factors ####
dat <- read.table("Complete RING.txt", header =TRUE)
str(dat)
dat$Vial <- as.factor(dat$Vial)
dat$Line <- as.factor(dat$Line)
dat$Fly <- as.factor(dat$Fly)
dat$Temp <- as.factor(dat$Temp)
str(dat)
datSUM <- summaryBy(X0.5_sec+X1_sec+X1.5_sec+X2_sec+X2.5_sec+X3_sec~Vial_nr+Concentration+Sex+Line+Vial+Temp,data=dat, FUN=sum)
fl<-levels(datSUM$Line)
colors = c("#e41a1c", "#377eb8", "#4daf4a", "#984ea3")
meltet <- melt(datSUM, id=c("Concentration","Sex","Line","Vial", "Temp", "Vial_nr"))
levels(meltet$variable) <- c('0,5 sec', '1 sec', '1,5 sec', '2 sec', '2,5 sec', '3 sec')
meltet20 <- subset(meltet, Line=="20")
meltet20$variable <- as.factor(meltet20$variable)
AllConcentrations <- levels(meltet20$Concentration)
for (i in AllConcentrations) {
meltet.i <- meltet20[meltet20$Concentration ==i,]
quartz()
print(dotplot(value~variable|Temp, group=Sex, data = meltet.i ,xlab="Time", ylab="Total height pr vial [mm above buttom]", main=paste('Line 20 concentration ', meltet.i$Concentration[1]),
key = list(points = list(col = colors[1:2], pch = c(1, 2)),
text = list(c("Female", "Male")),
space = "top"), col = colors, pch =c(1, 2))) }
I have tried with the quartz.save function, but that just overwrites the files. Im using a mac if that makes any difference.
When I want to save multiple plots in a loop I tend to do something like...
for(i in AllConcentrations){
meltet.i <- meltet20[meltet20$Concentration ==i,]
pdf(paste("my_filename", i, ".pdf", sep = ""))
dotplot(value~variable|Temp, group=Sex, data = meltet.i ,xlab="Time", ylab="Total height pr vial [mm above buttom]", main=paste('Line 20 concentration ', meltet.i$Concentration[1]),
key = list(points = list(col = colors[1:2], pch = c(1, 2)),
text = list(c("Female", "Male")),
space = "top"), col = colors, pch =c(1, 2))
dev.off()
}
This will create a pdf file for every level in AllConcentrations and save it in your working directory. It will paste together my_filename, the number of the iteration i, and then .pdf together to make each file unique. Of course, you will want to adjust height and width in the pdf function.
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.
require(tcltk)
ttMain <- tktoplevel()
tktitle(ttMain) <- "ttMain"
launchDialog <- function() {
ReturnVal <- modalDialog("First Gene", "Enter A Gene Name", "")
if (ReturnVal == "ID_CANCEL") return()
tkmessageBox(title = "Heatmap",
message = paste("Hello, ", ReturnVal, ".", sep = ""))
}
launchDlg.button <- tkbutton(ttMain, text = "Launch Dialog", command = launchDialog)
tkpack(launchDlg.button)
I want to rewrite the last line of the code to have the message return a heatmap. I have a dataframe with all the data necessary (data about gene expression in numerical form), called pedM, and ReturnVal represents a column name (a particular gene) within that dataframe. Please help.
Any tips that can be provided would be amazing.
Thanks in advance.
Here is an example that may help. Your code uses a modalDialog function that AFAIK does not exist. Here is an example of how to roll your own
library(tcltk)
library(tcltk2)
tkinput <- function(parent, title, label, okButLabel="Ok", posx=NULL, posy=NULL) {
if(!require(tcltk2)) stop("This function requires the package tcltk2.")
if(!require(tcltk)) stop("This function requires the package tcltk.")
# param checks
if(!is.character(title)) stop("invalid title argument - character required.")
if(!is.character(label)) stop("invalid label argument - character required.")
# toplevel
tclServiceMode(FALSE) # don't display until complete
win <- tktoplevel(parent)
#win <- .Tk.subwin(parent)
tkwm.title(win, title)
tkwm.resizable(win, 0,0)
#tkconfigure(win, width=width, height=height)
# commands
okCommand <- function() if(!tclvalue(bookmVar)=="") tkdestroy(win) else tkfocus(te)
cancelCommand <- function () {
tclvalue(bookmVar) <- ""
tkdestroy(win)
}
tkwm.protocol(win, "WM_DELETE_WINDOW", cancelCommand)
# pack
f <- tk2frame(win)
w <- tk2label(f, text=label, justify="right")
tkpack(w, side="left", padx=5)
bookmVar <- tclVar("")
te <- tk2entry(f, textvariable=bookmVar, width=40)
tkpack(te, side="left", padx=5, fill="x", expand=1)
tkpack(f, pady=5)
f <- tk2frame(win)
w <- tk2button(f, text=okButLabel, command=okCommand)
tkpack(w, side="left", padx=5)
w <- tk2button(f, text="Cancel", command=cancelCommand)
tkpack(w, side="left", padx=5)
tkpack(f, pady=5)
# position
if(is.null(posx)) posx <- as.integer((as.integer(tkwinfo("screenwidth", win)) - as.integer(tkwinfo("width", win))) / 2.)
if(is.null(posy)) posy <- as.integer((as.integer(tkwinfo("screenheight", win)) - as.integer(tkwinfo("height", win))) / 2.)
geom <- sprintf("+%d+%d", posx, posy)
#print(geom)
tkwm.geometry(win, geom)
# run
tclServiceMode(TRUE)
ico <- tk2ico.load(file.path(R.home(), "bin", "R.exe"), res = "R")
tk2ico.set(win, ico)
tk2ico.destroy(ico)
tkfocus(te)
tkbind(win, "<Return>", okCommand)
tkbind(win, "<Escape>", cancelCommand)
tkwait.window(win)
tkfocus(parent)
return(tclvalue(bookmVar))
}
To plot an heatmap instead of a messagebox, you can use the tkrplot function
library(tkrplot)
heat_example <- function() {
x <- as.matrix(mtcars)
rc <- rainbow(nrow(x), start=0, end=.3)
cc <- rainbow(ncol(x), start=0, end=.3)
hv <- heatmap(x, col = cm.colors(256), scale="column",
RowSideColors = rc, ColSideColors = cc, margins=c(5,10),
xlab = "specification variables", ylab= "Car Models",
main = "heatmap(<Mtcars data>, ..., scale = \"column\")")
}
launchDialog <- function() {
ReturnVal <- tkinput(parent=ttMain, title="First Gene", label="Enter A Gene Name")
if (ReturnVal == "") return()
hmwin <- tktoplevel(ttMain)
img <- tkrplot(hmwin, heat_example)
tkpack(img, hmwin)
}
ttMain <- tktoplevel()
tktitle(ttMain) <- "ttMain"
launchDlg.button <- tkbutton(ttMain, text = "Launch Dialog", command = launchDialog)
tkpack(launchDlg.button, ttMain)
This code produces a heatmap, but gives also an error message I cannot resolve. Maybe someone else here can find the problem.