Freeze panes Shiny App Rstudio - r

I used this link to color cells in a table: R shiny color dataframe
I've tried to change this code to allow for locking the first column in a table as the user scrolls from left to right, but haven't been able to figure it out.
Can anyone help on this?
colortable <- function(htmltab, css, style="table-condensed table-bordered"){
tmp <- str_split(htmltab, "\n")[[1]]
CSSid <- gsub("\\{.+", "", css)
CSSid <- gsub("^[\\s+]|\\s+$", "", CSSid)
CSSidPaste <- gsub("#", "", CSSid)
CSSid2 <- paste(" ", CSSid, sep = "")
ids <- paste0("<td id='", CSSidPaste, "'")
for (i in 1:length(CSSid)) {
locations <- grep(CSSid[i], tmp)
tmp[locations] <- gsub("<td", ids[i], tmp[locations])
tmp[locations] <- gsub(CSSid2[i], "", tmp[locations],
fixed = TRUE)
}
tmp[1] = "<table class=\"display responsive no-wrap\" width=\"100%\" cellspacing=\"0\" cellpadding =\"0\">"
htmltab <- paste(tmp, collapse="\n")
Encoding(htmltab) <- "UTF-8"
list(
tags$style(type="text/css", paste(css, collapse="\n")),
tags$script(sprintf(
'$( "table" ).addClass( "table %s" );', style
)),
HTML(htmltab)
)
}

Related

Issue with R-Script populating required content in excel

This script outputs excel spreadsheets of different region. However, since I included a column "Later", changed the corresponding template to also include the column "Later" and increased the number on this line "df <- subset(clist[,c(1:18, 20:29)" from 28 to 29 (given the increased column). The output on the column "group" has come back with its content, but with quotation mark and some instance with CHAR(10).
Is there anyway I can edit this script to have column "group" outcome its content without the quotation marks. Please help!! help! I have struggled with this since. See script below
NB changes made to the original script are as follows
inclusion of later in the sqlcode
changing the df <- subset(clist[,c(1:18, 20:28)" to df <- subset(clist[,c(1:18, 20:29)
Changing the second df <- subset(clist[,c(1:17, 19:28)] to df <- subset(clist[,c(1:18, 20:29)]
#####Constants#####
requiredpackages <- c("XLConnect", "RPostgreSQL", "svDialogs", "getPass")
reqpackages <- function(requiredpackages){
for( i in requiredpackages ){
if( ! require( i , character.only = TRUE ) ) {
install.packages( i , dependencies = TRUE )
library( i , character.only = TRUE )
}
}
}
# set the version to 1.0.5
packageurl <- "https://cran.r-project.org/src/contrib/Archive/XLConnect/XLConnect_1.0.5.tar.gz"
install.packages(packageurl, repos=NULL, type="source")
library(XLConnect)
library(RPostgreSQL)
library(svDialogs)
library(getPass)
source("N:/Ana/Code/Analysiss/Rational/R SQL working/postgresql-avd.R")
#####Retrieve data from analysis server#####
sqlcode <- paste("SELECT concat_ws(';',datacompletion,sortprovider) as datacompletion,ba,outstandingdata,provider,summary,
m,m_hos,m_sur,m_for,m_dob,ed,
bkhos,delhos,
pregnancy,b_d,
b,b_na,
group,groupsw,later,estimated,
screening,date,screening2,
booking,city,use,con,water
FROM common.etl_chasing
where ((date::text like '%",tperiod,"%' or date::text like '%",cperiod,"%')
and (anomalygroup like '%Down%' or group like '%Edwards%' or group like '%Patau%'))
or eddfyear like '%", fperiod,"%' or cleanyear like '%", cperiod, "%'", sep='')
con <- createConnection()
clist <- dbGetQuery(con, sqlcode)
dbDisconnect(con)
#####Create new folder on PID drive to output chasing lists to#####
dirname <- paste("P:/Data/Antenatal/Testing/", Sys.Date(),sep='')
dir.create(dirname)
#####Export CSV of all data#####
write.csv(clist,paste(dirname,"/masterlist.csv",sep=''))
#####Copy template for all individual providers#####
sortproviders <- unique(clist$sortprovider)
inpath <- "P:/Data/National/Antenatal/Template17b.xlsx"
for (i in seq_along(sortproviders)) {
outpath <- paste(dirname,"/",sortproviders\[i\]," AN LIST.xlsx", sep='')
file.copy(from = inpath, to = outpath)
}
#####Populate templates for individual providers#####
swpatterns <- c("68 - ", "70 - ", "72 - ", "73 - ", "84 - ", "93 - ", "94 - ", "95 - ", "96 - ", "99 - ")
#grepl(paste(swpatterns, collapse = "|"), sortproviders\[1\])
#otherpatterns \<- c("72 - ", "96 - ", "73 - ", "93 - ", "94 - ", "72 - ", "99 - ")
#swsortproviders \<- unique(grep(paste(swpatterns, collapse = "|"), sortproviders, value = TRUE))
#restsortprividers \<- unique(grep(paste(otherpatterns, collapse = "|"), sortproviders, value = TRUE))
for (i in seq_along(sortproviders)) {
outpath \<- paste(dirname,"/",sortproviders\[i\]," AN LIST.xlsx", sep='')
if (grepl(paste(swpatterns, collapse = "|"), sortproviders\[i\]) == FALSE) {
df <- subset(clist[,c(1:18, 20:29)], sortprovider == sortproviders[i])
dfformulacol <- as.vector(df$anomalygroup)
df <- cbind(df, df)
XLConnect::writeWorksheetToFile(outpath, df, sheet = "trust list", startRow = 4, header = FALSE, styleAction = XLC$"STYLE_ACTION.NONE")
wb <- loadWorkbook(filename = outpath, create = FALSE)
for (j in seq_along(dfformulacol)) {
setCellFormula(wb, "trust list", j+3, 18, dfformulacol[j])
}
for (k in seq_along(dfformulacol)) {
setCellFormula(wb, "trust list", k+3, 45, dfformulacol[k])
}
saveWorkbook(wb)
rm(wb)
} else {
df <- subset(clist[,c(1:18, 20:29)], sortprovider == sortproviders[i])
df <- cbind(df, df)
XLConnect::writeWorksheetToFile(outpath, df, sheet = "trust list", startRow = 4, header = FALSE, styleAction = XLC$"STYLE_ACTION.NONE")
wb <- loadWorkbook(filename = outpath, create = FALSE)
saveWorkbook(wb)
rm(wb)
}
rm(df)
xlcFreeMemory()
}
#####################################

How to make this XML code generate bold text?

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
}

Shiny showing same result even if I upload new files

I am trying to build a shiny app where extract_text and extract_table functions from R tabulizer package are used. But the problem is in an instance the results from the first file I upload remains, i.e. if I upload a pdf file the desired results appear, but even if I upload a new file the results don't change unless I stop and start a new instance. Here is my server.R code-
shinyServer(function(input,output,session) {
fund<-reactive({
inFile <- input$file1
if (is.null(inFile))
{return(NULL)} else {
rr<-extract_text(inFile$datapath, pages =2)
e1<-extract_tables(inFile$datapath, pages =1)
e2<-extract_tables(inFile$datapath, pages =2)
rr<-gsub("\r\n", " ", rr)
ss<-unlist(strsplit(rr, "Total & WAR:"))
gr<-grep("Reverse Repo With Bank", ss)
if (length(gr)>=1) {
sk<-gsub("(?<=[\\s])\\s*|^\\s+|\\s+$", "", ss[gr], perl=T)
sn<-unlist(strsplit(sk, " ", fixed=T))
grp<-grep("Limited", sn)
dm<-matrix(nrow=length(grp), ncol=4)
party<-c()
for (i in 1:length(grp)){
dm[i,]<-sn[(grp[i]+1):(grp[i]+4)]
party[i]<-paste(sn[(grp[i]-2):(grp[i])],sep="", collapse=" ")
}
dm<-as.data.frame(dm)
names(dm)<-c("Amount", "Rate", "DealDate", "MaturityDate" )
dm$PartyName<-party
dm$Tenure<-rep("", times=nrow(dm))
dm<-dm[,c(5:6,1:4)]
dn<-data.frame(PartyName="Product Name : Reverse Repo with Bank", Tenure="", Amount="", Rate="", DealDate="", MaturityDate="")
dnn<-data.frame(PartyName="Total & WAR:", Tenure="", Amount="", Rate="", DealDate="", MaturityDate="")
dm<-rbind(dn,dm,dnn)
}
if (length(e1)>1) {
l1<-dim(e1[[1]])[1]
l2<-dim(e1[[2]])[1]
m<-c(l1,l2)
e<-e1[[which(m==max(m))]]
} else {e=e1[[1]]}
gop<-grep("Party Name", e[,1], fixed=T)
e<-e[-(1:(gop-1)),]
e[,3]<-gsub("(?<=[\\s])\\s*|^\\s+|\\s+$", "", e[,3], perl=T)
if (ncol(e)==4){
ss<-strsplit(e[,3], " ")
s1<-sapply(ss, function(x) x[1])
s2<-sapply(ss, function(x) x[2])
sss<-strsplit(e[,4], " ")
s1s<-sapply(sss, function(x) x[1])
s2s<-sapply(sss, function(x) x[2])
e<-cbind(e[,1:2],s1,s2,s1s,s2s)
} else if (ncol(e)==5) {
sss<-strsplit(e[,5], " ")
s1s<-sapply(sss, function(x) x[1])
s2s<-sapply(sss, function(x) x[2])
e<-cbind(e[,1:4],s1s,s2s)
}
d<-rbind(e[-1,],e2[[1]][-1,])
d<-as.data.frame(d)
colnames(d)<-c("PartyName", "Tenure", "Amount", "Rate", "DealDate", "MaturityDate")
if (length(gr)>=1){
d<-rbind(d,dm)
}
row.names(d)<-1:nrow(d)
d$Rate<-as.numeric(as.character(d$Rate))
w<-which(d$Rate>7)
d<-d[-w,]
d$IncomeType<-rep(NA, nrow(d))
d$Rate[is.na(d$Rate)]<-0
levels<-c(-1,1,5,7)
labels<-c("Invalid","Low Income", "Medium Income")
d$IncomeType<-cut(d$Rate, levels, labels)
d$Period<-as.Date(d$MaturityDate, format="%d/%m/%Y")-Sys.Date()
d$Period[is.na(d$Period)]<-1
levels1<-c(-50,-1,1,15,30,5000)
labels1<-c("Already Matured", "Within 1 Day", "Within 2 to 15 Days", "Within 16 to 30 Days", "More than 1 Month")
d$MaturityType<-cut(as.numeric(d$Period), levels1, labels1)
m<-grep("Product Name : Commercial Paper", d[,1], fixed=T)
d<-d[-m,]
g1<-grep("Product Name",d[,1], fixed=T)
name<-d[g1,1]
name<-as.character(name)
name<-sapply(strsplit(name,": "), "[", 2)
g2<-grep("Total & WAR",d[,1], fixed=T)
w<-which(d[,1]=="Product Name : Call Borrowing with Bank")
if (length(w)>=1){
d<-d[-(g1[which(g1==w)]:g2[which(g1==w)]),]
name<-name[-which(g1==w)]
g1<-grep("Product Name",d[,1], fixed=T)
g2<-grep("Total & WAR",d[,1], fixed=T)
}
Product<-c()
for (i in 1: length(g1)) {
Product[(g1[i]):(g2[i])]<-name[i]
}
d$Product<-Product
d<-d[!(is.na(d$DealDate)|d$DealDate==""),]
d$Amount<-as.numeric(gsub(",", "", d$Amount))
Remaining<-as.Date(d$MaturityDate, format="%d/%m/%Y")-Sys.Date()
d$Remaining<-ifelse(is.na(Remaining)!=TRUE, Remaining, "ON CALL")
d<-d[order(d$IncomeType,d$Product),]
d<-d[,c(1,10,3,4,7,5,6,11)]
d$DealDate<-as.character(d$DealDate)
d$MaturityDate<-as.character(d$MaturityDate)
d$Period<-as.Date(d$MaturityDate, format="%d/%m/%Y")-Sys.Date()
d$Period[is.na(d$Period)]<-1
levels1<-c(-5000,0,1,15,30,5000)
labels1<-c("Already Matured", "Matures Next Day", "In Between 2 to 15 Days", "In Between 16 to 30 Days", "More than 1 Month")
d$MaturityType<-cut(as.numeric(d$Period), levels1, labels1)
d1<-d[,1:8]
d1<-d1[order(d$IncomeType,d$Product),]
rate<-sum(as.numeric(d1$Amount)*as.numeric(d1$Rate)/sum(as.numeric(d1$Amount)))
d1<-as.data.frame(apply(d1, 2, function(x) gsub("^\\s+|\\s+$", "", x)), stringsAsFactors = F)
d1$MaturityDate[is.na(d1$MaturityDate)]<-""
d1[(nrow(d1)+1),]<-c("Total","",sum(as.numeric(d1$Amount)),rate, rep("", times=4))
row.names(d1)<-1:nrow(d1)
tt<-daply(d,.(IncomeType, Product), summarize, sum(Amount),.drop_i = F)
tt<-tt[-1,]
rrr<-rowSums(apply(tt,2, as.numeric))
tt<-cbind(tt,Total=rrr)
cc<-colSums(apply(tt, 2, as.numeric))
tt<-rbind(tt,Total=cc)
tt1<-daply(d,.(IncomeType, MaturityType), summarize, sum(Amount),.drop_i = F)
tt1<-tt1[-1,]
rrr<-rowSums(apply(tt1,2, as.numeric))
tt1<-cbind(tt1,Total=rrr)
cc<-colSums(apply(tt1, 2, as.numeric))
tt1<-rbind(tt1,Total=cc)
ECRR<-as.numeric(gsub(",","",e2[[2]][2,2]))-as.numeric(gsub(",","",e2[[2]][1,2]))
if(ECRR<0){
ECRR<-0
} else {ECRR=ECRR}
ECRR<-data.frame(ECRR)
names(ECRR)<-"OMG"
list(ECRR=ECRR,tt=tt,tt1=tt1,d1=d1)}
})
output$fileUploaded <- reactive({
return(!is.null(fund()))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
name<-c("ECRR","tt","tt1","details")
save.xlsx <- function (file, ...)
{
require(xlsx, quietly = TRUE)
objects <- list(...)
fargs <- as.list(match.call(expand.dots = TRUE))
objnames <- as.character(fargs)[-c(1, 2)]
nobjects <- length(objects)
for (i in 1:nobjects) {
if (i == 1)
write.xlsx(objects[[i]], file, sheetName = name[i])
else write.xlsx(objects[[i]], file, sheetName = name[i],
append = TRUE)
}
print(paste("Workbook", file, "has", nobjects, "worksheets."))
}
output$F<-renderTable({fund()$ECRR})
output$G<-renderTable({fund()$tt},rownames=T)
output$H<-renderTable({fund()$tt1},rownames=T)
output$I<-renderTable({fund()$d1},rownames=T)
output$downloadData <- downloadHandler(
filename = "ALM.xlsx",
content = function(file) {
save.xlsx(file,fund()$ECRR,fund()$tt,fund()$tt1,fund()$d1)
}
)
})
And ui.R
library(shiny)
shinyUI(pageWithSidebar (
headerPanel( "Fund"),
sidebarPanel(width=3,
fileInput('file1', 'Choose a file to upload',
accept = c(
'.pdf'
)),
helpText("(Only .pdf files can be uploaded"),
conditionalPanel("output.fileUploaded",
downloadButton('downloadData'))
),
mainPanel (
tabsetPanel(
tabPanel("ECRR", tableOutput("F")),
tabPanel("Product wise Distribution", tableOutput("G")),
tabPanel("Maturity wise Distribution", tableOutput("H")),
tabPanel("Details", tableOutput("I"))
))
)
)
If anybody wants to test the files I am trying to upload here are 2 of them
[File1][1]
[File2][2]
Sorry for the very messy code and thanks in advance.

Add tooltip to abbreviated data table names

How can you add a tool tip to column header in a data table display
output$table <- renderDataTable({
df <- iris
colnames(df) <- sapply(names(df), function(x) abbreviate(x))
df
})
The actual data frame i'm using (which I can't show) has very long names and there are >20 columns. So abbreviating is necessary to show the entire data frame with minimal horizontal scrolling. I'm looking for a way to add a hover over tool tip that shows the full, un-abbreviated name of each column when you hover over an abbreviated column header.
dat <- iris[1:3,]
names(dat) <- c(
"A long name",
"Another long name",
"Yet another long name",
"This name is long as well",
"This one is not short"
)
headerCallback <- c(
"function(thead, data, start, end, display){",
" var ncols = data[0].length;",
sprintf(" var shortnames = [%s]",
paste0(paste0("'",abbreviate(names(dat)),"'"), collapse = ",")),
sprintf(" var tooltips = [%s];",
paste0(paste0("'",names(dat),"'"), collapse = ",")),
" for(var i=0; i<ncols; i++){",
" $('th:eq('+i+')',thead).attr('title', tooltips[i]).text(shortnames[i]);",
" }",
"}"
)
datatable(dat, rownames = FALSE,
options = list(
headerCallback = JS(headerCallback)
)
)

Using tcltk to output a heatmap

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.

Resources