Consider either function which (for rstudio) will open something in the viewer if y = TRUE and in your browser if y = FALSE. You can force the whatever to open in your browser via options(viewer = NULL) (and then you need to reset to before), but I can't get this to work inside functions using the normal on.exit approach. Tested on windows and osx.
f <- function(x, y = TRUE) {
if (y) {
oo <- getOption('viewer')
on.exit(options(viewer = oo))
options(viewer = NULL)
} else options(viewer = NULL)
print(getOption('viewer'))
DT::datatable(x)
}
g <- function(x, y = TRUE) {
if (y) {
oo <- getOption('viewer')
on.exit(options(viewer = oo))
options(viewer = NULL)
} else options(viewer = NULL)
print(getOption('viewer'))
htmlTable::htmlTable(x)
}
## in rstudio, returns the viewer function
getOption('viewer')
# function (url, height = NULL)
# ...
## opens in viewer despite `options(viewer = NULL)`
g(mtcars)
# NULL
## again returns the function, ie, reset my options to before g call successfully
getOption('viewer')
# function (url, height = NULL)
# ...
## opens in browser but leaves `options(viewer = NULL)` after exiting
g(mtcars, FALSE)
# NULL
getOption('viewer')
# NULL
It seems like the viewer isn't respecting my options within the function environment with either just some html (g) or a widget (f). I thought both would use viewer = NULL inside the function and return my options the way they were upon exiting so that I can control where I want to view the result.
Or is there a better way of doing this for both html and widgets? I have tried the options argument in DT::datatable to no avail, but this wouldn't help for the htmlTable::htmlTable case.
The only other approach I can think of is to write all the code to a temp file and use if (rstudio) rstudio::viewer(tempfile) else browseURL(tempfile) which I think is a lot of work for something seemingly so straight-forward.
Although this isn't a fix, I think it illustrates what's going on. Try adding a Sys.sleep() call in the on.exit() handler:
f <- function(x) {
viewer <- getOption("viewer")
on.exit({
print("Restoring viewer...")
Sys.sleep(3)
options(viewer = viewer)
}, add = TRUE)
options(viewer = NULL)
DT::datatable(x)
}
## opens in viewer despite `options(viewer = NULL)`
f(mtcars)
You'll notice that RStudio doesn't 'decide' what to do with the result of DT::datatable() call until after the on.exit() handler has finished execution. This means that, by the time RStudio wants to figure out to do with the result, the viewer has already been restored! Odds are, RStudio waits until R is no longer 'busy' to decide how to display the resulting content, and by then is too late for temporary changes to the viewer option.
Note that this doesn't explain the htmlTable behaviour. My best guess is that there is some kind of race condition going on; the lost viewer option seems to go away with strategically placed Sys.sleep() calls...
Unfortunately, working around this means avoiding the use of on.exit() call -- unless we can figure out to handle this in RStudio, of course.
Here's one way you could get this functionality by writing the code to a temporary file and using browseURL or whatever you like.
The gist of both f and g are the same, so you could have one function to handle any type of html code or widget I suppose. And probably widgets need to be selfcontained = TRUE.
f <- function(x, y = TRUE) {
x <- if ((inherits(x, 'iplot'))) x else DT::datatable(x)
if (!y) {
htmlFile <- tempfile(fileext = '.html')
htmlwidgets::saveWidget(x, htmlFile, selfcontained = TRUE)
utils::browseURL(htmlFile)
} else x
}
g <- function(x, y = TRUE) {
x <- htmlTable::htmlTable(x)
if (!y) {
htmlFile <- tempfile(fileext = '.html')
writeLines(x, con = htmlFile)
utils::browseURL(htmlFile)
} else x
}
## opens in viewer
g(mtcars)
## opens in browser
g(mtcars, FALSE)
## same for widgets
f(mtcars)
f(mtcars, FALSE)
f(qtlcharts::iplot(1:5, 1:5), FALSE)
## and my options haven't changed
getOption('viewer')
# function (url, height = NULL)
# ...
Side note that this is actually the proper way to have htmlTable::htmlTable use a different viewer, but g should work for any html.
library('htmlTable')
print(htmlTable(mtcars), useViewer = utils::browseURL)
Related
I want my function to print nice-looking tables, whether it's called from base R or from an RStudio Notebook (.Rmd file). The function should figure out where it's being called from, and adjust the table accordingly. I want the function to be easy to use, and don't want the user to have to specify anything about where the function is being called from.
I can achieve some of this with huxtable, but the user still has to modify the code a little. (I think this would work similarly with kable.)
Here is the function definition:
library(huxtable)
func = function() {
table = hux(head(iris))
# Color of table border: white on screen / base R, black in HTML
color = if(isTRUE(all.equal(getOption('huxtable.print') , huxtable::print_screen))) "white" else "black"
table = set_all_borders(table, brdr(color = color))
print(table)
}
In base R, I can just call the function:
# Base R
func()
But in an RStudio Notebook, I need to make a couple of changes when calling the function, namely:
{r, results="asis"}
options("huxtable.print" = huxtable::print_html)
The call looks like this:
```{r, results="asis"}
# RStudio
options("huxtable.print" = huxtable::print_html)
func()
```
Is there a better solution where the user can call the function the same way in base R and RStudio?
Maybe something like this?
library(huxtable)
func = function(table) {
html_output = isTRUE(all.equal(getOption('huxtable.print') ,
huxtable::print_html) ||
guess_knitr_output_format() == "html"
color = if(html_output) "black" else "white"
table = set_all_borders(table, brdr(color = color))
print(table)
}
Thanks to #dash2 for giving me the idea. Here is the function that does what I want:
library(huxtable)
func = function() {
table = hux(head(iris))
if (guess_knitr_output_format() == "") { # base R
table = set_all_borders(table, brdr(color = "white"))
print(table, colnames = FALSE)
} else { # knitr / RStudio
table = set_all_borders(table, brdr(color = "black"))
huxtable:::knit_print.huxtable(table, colnames = FALSE)
}
}
func()
I am trying to extend websocket::Websocket with a method that sends some data and returns the message, so that I can assign it to an object. My question is pretty much identical to https://community.rstudio.com/t/capture-streaming-json-over-websocket/16986. Unfortunately, the user there never revealed how they solved it themselves. My idea was to have the onMessage method return the event$data, i.e. something like:
my_websocket <- R6::R6Class("My websocket",
inherit = websocket::WebSocket,
public = list(
foo = function(x) {
msg <- super$send(paste("x"))
return(msg)
} )
)
load_websocket <- function(){
ws <- my_websocket$new("ws://foo.local")
ws$onMessage(function(event) {
return(event$data)
})
return(ws)
}
my_ws <- load_websocket()
my_ws$foo("hello") # returns NULL
but after spending a good hour on the Websocket source code, I am still completely in the dark as to where exactly the callback happens, "R environment wise".
You need to use super assignment operator <<-. <<- is most useful in conjunction with closures to maintain state. Unlike the usual single arrow assignment (<-) that always works on the current level, the double arrow operator can modify variables in parent levels.
my_websocket <- R6::R6Class("My websocket",
inherit = websocket::WebSocket,
public = list(
foo = function(x) {
msg <<- super$send(paste("x"))
return(msg)
} )
)
load_websocket <- function(){
ws <- my_websocket$new("ws://foo.local")
ws$onMessage(function(event) {
return(event$data)
})
return(ws)
}
my_ws <- load_websocket()
my_ws$foo("hello")
I'm using slackr to send alert messages to a Slack channel. It works great except the message format is not great and I want to improve it.
install_github("hrbrmstr/slackr")
library(slackr)
slackr_setup(channel="#alerts", username="Mark Davis",
incoming_webhook_url = "https://hooks.slack.com/services/T31P8UDAB/BCH4HKQSC/*********",
api_token = "*********", echo = F)
alert="On Monday, 2018-09-03 # 2pm Pacific..."
slackr(alert)
Here is an example of how a message from slackr looks in Slack:
Here is an example of how I'd like it to look:
slackr doesn't seem to have many options in the way of formatting. I was thinking of building an image and inserting that, but I'm having trouble building an image out of a text file using R.
Perhaps there is another api I could call that could take my text and format it for slack?
I'm open to any suggestions.
Addendum:
Slackr has an option to upload files, so my latest attempt is to create an image from the text message and upload that object.
I am able to create a png file from the text message using the magick library. I created an image with a colored background, and I simply add the message text to the image:
library(magick)
alert_picture <- image_read('alert_480x150_dark_red.png')
alert_picture=image_annotate(alert_picture, DreamCloud_Alert, size = 20, gravity = "southwest",
color = "white", location = "+10+10")
image_write(alert_picture, path = "alert_picture.png", format = "png")
The image looks pretty good (although there doesn't seem to be an easy way to bold or underline specific words in the message), but the obstacle now is that I can't get the upload command to work.
slackr_upload(filename = "alert_picture.png")
I don't get any error messages but nothing is uploaded to slack.
I got around this issue by using the httr package to execute the post image function to slack.
Thanks to Adil B. for providing the solution:
Post Image to Slack Using HTTR package in R
I am not sure this is what you meant, but I solved allowing formatting like in a regular slack message by altering the slackr_bot() function and just removing the 2 sets of 3 back-ticks at the end of the code where it says text. Then just call it slackr_bot1() or something, and then you can post formatted messages. This is the function after the back-ticks removal:
slackr_bot1 <- function(...,
channel=Sys.getenv("SLACK_CHANNEL"),
username=Sys.getenv("SLACK_USERNAME"),
icon_emoji=Sys.getenv("SLACK_ICON_EMOJI"),
incoming_webhook_url=Sys.getenv("SLACK_INCOMING_URL_PREFIX")) {
if (incoming_webhook_url == "") {
stop("No incoming webhook URL specified. Did you forget to call slackr_setup()?", call. = FALSE)
}
if (icon_emoji != "") { icon_emoji <- sprintf(', "icon_emoji": "%s"', icon_emoji) }
resp_ret <- ""
if (!missing(...)) {
# mimics capture.output
# get the arglist
args <- substitute(list(...))[-1L]
# setup in-memory sink
rval <- NULL
fil <- textConnection("rval", "w", local = TRUE)
sink(fil)
on.exit({
sink()
close(fil)
})
# where we'll need to eval expressions
pf <- parent.frame()
# how we'll eval expressions
evalVis <- function(expr) withVisible(eval(expr, pf))
# for each expression
for (i in seq_along(args)) {
expr <- args[[i]]
# do something, note all the newlines...Slack ``` needs them
tmp <- switch(mode(expr),
# if it's actually an expresison, iterate over it
expression = {
cat(sprintf("> %s\n", deparse(expr)))
lapply(expr, evalVis)
},
# if it's a call or a name, eval, printing run output as if in console
call = ,
name = {
cat(sprintf("> %s\n", deparse(expr)))
list(evalVis(expr))
},
# if pretty much anything else (i.e. a bare value) just output it
integer = ,
double = ,
complex = ,
raw = ,
logical = ,
numeric = cat(sprintf("%s\n\n", as.character(expr))),
character = cat(sprintf("%s\n\n", expr)),
stop("mode of argument not handled at present by slackr"))
for (item in tmp) if (item$visible) { print(item$value, quote = FALSE); cat("\n") }
}
on.exit()
sink()
close(fil)
# combined all of them (rval is a character vector)
output <- paste0(rval, collapse="\n")
loc <- Sys.getlocale('LC_CTYPE')
Sys.setlocale('LC_CTYPE','C')
on.exit(Sys.setlocale("LC_CTYPE", loc))
resp <- POST(url = incoming_webhook_url, encode = "form",
add_headers(`Content-Type` = "application/x-www-form-urlencoded",
Accept = "*/*"), body = URLencode(sprintf("payload={\"channel\": \"%s\", \"username\": \"%s\", \"text\": \"%s\"%s}",
channel, username, output, icon_emoji)))
warn_for_status(resp)
}
return(invisible())
}
slackr_bot1("*test* on time")
Is there a way to set options within an environment? Something like
tmp_env = new.env()
within(tmp_env, options(mc.core = 16))
with(tmp_env, {
# run parallel code here
})
I want to switch between using options(mc.core = 16) and options(mc.core = 1) explicitly and don't want to accidentally set off a parallelized computation.
Use a function or other closure (e.g., local()) to set the option, and use on.exit() to guarantee restoration on exit
fun = function() {
old.opt = options(mc.cores=12)
on.exit(options(old.opt))
## do work
}
You could get fancy with something like (based on with.default)
withp = function(expr, cores=4) {
old.opt = options(mc.cores=cores)
on.exit(options(old.opt))
eval(substitute(expr), enclos=parent.frame())
}
and use
withp({
message("hello")
res <- mclapply(1:20, function(i) Sys.getpid())
table(unlist(res))
}, cores=3)
In my code I plot a function and then raise a dialog to ask the user about it. The issue is that the dialog is raised before the plot is updated, so the user sees whatever was last in the plot window (I'm using R-studio). How can I solve this?
Example:
for(i in (1:3)) {
x = (1:100); #not the real vectors...just an example
f = (601:700);
plot(x,f)
ans = winDialog(type = c("yesno"), "is it any good?")
}
Searching for "R flush plot" led me to this solution. At least on my system I had to replace Sys.sleep(0) by Sys.sleep(1). But then it works.
for(i in (1:3)) {
x = (1:100); #not the real vectors...just an example
f = x^i
plot(x,f)
Sys.sleep(1)
ans = winDialog(type = c("yesno"), "is it any good?")
}