Context
I need to use R metaprogramming for use with the framework Shiny, as their modules and event handlers depend on metaprogramming for passing expressions and executing it in the right context for evaluation to chain with pre-defined input, output, and session objects.
To simplify the problem, I'm going to use the example of a source() function.
Example
To run Shiny, Shiny requires two objects: ui and server. The server is a function: server <- function(input, output, session).
All I want to do is this:
server <- function(input, output, session) {
source('fileA.R', local=TRUE)
source('fileB.R', local=TRUE)
}
This works on its own. However, I have about ten different files to include. So I created a function to return the required code to execute within it:
run_server <- function(str) {
names <- strsplit(x=str, split='/')
code <- character()
for (i in 1:length(names)) {
module_names <- ''
filenames <- ''
module_names[i] <- names[[i]][length(names[[i]])]
filenames[i] <- paste0(str[i], '/server_', module_names[i], '.R')
code <- paste0(code, "source(\'", filenames[i], "\'", ", local = TRUE)", "\n")
}
return(parse(text=code))
}
This works fine... except that it returns the type expression from R, which is different than the return type of quote or substitute. It also means that if I try to use eval/evalq on this, it doesn't work the way I expect.
I've resorted to trying to create the server function using another helper function:
make_server <- function(...) {
code <- eval(substitute(...))
func <- bquote(function(input, output, session) {
.(code)
})
return(
func
)
}
But once again, the function body is a bit weird--it still has the expression() function wrapped around the contents of its body:
function(input, output, session) {
expression(source("modules/upload_rds/server_upload_rds.R",
local = TRUE), source("modules/download_rds/server_download_rds.R",
local = TRUE), source("modules/fileupload/server_fileupload.R",
local = TRUE), source("modules/normalization/server_normalization.R",
local = TRUE), source("modules/outlier_zmedian/server_outlier_zmedian.R",
local = TRUE), source("modules/basic_nmf/server_basic_nmf.R",
local = TRUE), source("modules/monocle/server_monocle.R",
local = TRUE), source("modules/deseq2/server_deseq2.R",
local = TRUE), source("modules/fem_analysis/server_fem_analysis.R",
local = TRUE), source("modules/topGO/server_topGO.R",
local = TRUE), source("modules/cluster_profiler/server_cluster_profiler.R",
local = TRUE), source("modules/scde/server_scde.R", local = TRUE),
source("modules/edgeR/server_edgeR.R", local = TRUE))
}
And this doesn't evaluate as if the code was simply copy-pasted or truly substituted like a C preprocessor would.
expression() vs. quote()
Reading this answer here, it appears that an expression is a vector of calls, etc. So the natural thing to do would be to just apply something like unlist() or c(). But this doesn't work. Does anyone have a solution to this?
Related
I've been trying to write a code that optimizes a electricity production facility that must be a web application in R. I'm using shiny package for this issue. At the server part of the code, there must be some calculations made so I've written some equations for this issue. Here's my shinyServer part;
function(input, output){
abc <- reactive({
which(paste(input$tarih, input$zaman, sep = " ") == data$Tarih.ve.Saat)
def <- reactive({
which(month(input$tarih) == aylıkdata$Ay)
})
})
output$baseload <- renderPrint(
((as.numeric(data[abc(),3]) * input$paste("bload", def(), sep ="")) - (input$paste("gaz", def(), sep = "")*input$gazfiyatı) - (input$ürtvergi*input$paste("bload", def(), sep ="")))
)
output$mkud <- renderPrint(
((as.numeric(data[abc(),3]) * input$mkudüretim) - (input$mkudgazkullanımı*input$gazfiyatı) - (input$ürtvergi*input$mkudüretim))
)
output$stup <- renderPrint(
((as.numeric(data[abc(),3]) * input$supüretim) - (input$supgazkullanımı*input$gazfiyatı) - (input$ürtvergi*input$supüretim))
)
output$sdown <- renderPrint(
((as.numeric(data[abc(),3]) * input$sdownüretim) - (input$sdowngazkullanımı*input$gazfiyatı) - (input$ürtvergi*input$sdownüretim))
)
}
)
However, when I run the app I get the error:
Warning: Error in [.data.table: i has evaluated to type closure. Expecting logical, integer or double.
What can be situation there? where is the fault?
Taking a stab at this one as I don't have data to confirm/deny whether this will work... (without spending more time than I would like :p)
My feeling is you can't do data[abc(),3] as it doesn't expect a reactive expression within a data.table. I would try to create a reactive data set, and then use this instead. I can't fully interpret your code as you have reactives within reactives... does this work?
This could fail as I don't use shiny that much, but hopefully the idea can be built upon
# instead try to return the reactive data object
reactive_data <- reactive({
con <- which(paste(input$tarih, input$zaman, sep = " ") == data$Tarih.ve.Saat)
data[con,]
})
#... other things eg the def <- reactive(.. command
# instead, call the reactive data that's the data.table and use [,3] to filter or instead just put [,3] in the output above if nothing else is ever used
output$mkud <- renderPrint(
((as.numeric(reactive_data()[,3]) * input$mkudüretim) - (input$mkudgazkullanımı*input$gazfiyatı) - (input$ürtvergi*input$mkudüretim))
)
I am looking for some help please to print a reactive value in a Shiny session into a docx with WordR. A very stripped down version of my app is presented below.
The code for the docx template is `r reactive({declared_user()})` (which is bookended with MS Word’s formatting symbols). I don’t know how to show the format symbols or provide the docx template here on SO but that’s the only applicable code.
I have tried numerous ways of wrapping the declared_user() in a reactive context in both the r file and docx but still can’t seem to see either value/user in ‘slt_input’ printing out in rprt_out.docx.
All that prints out is…
function () { .dependents$register() if (.invalidated || .running) { ..stacktraceoff..(self$.updateValue()) } if (.error) { stop(.value) } if (.visible) .value else invisible(.value) }
library(shiny)
library(WordR)
library(officer)
library(dplyr)
ui <- fluidPage(
selectInput('slt_input', 'name', choices = c("god", 'devil')),
actionButton("btn_inline", 'inline')
)
server <- function(input, output, session) {
declared_user <- reactive({
input$slt_input
})
observeEvent(input$btn_inline,{
renderInlineCode("rprt_tmplt.docx", "rprt_out.docx")
})
}
shinyApp(ui, server)
Here is a solution. I think 2 things complicated the issue:
renderInlineCode extracts the R code from the .docx template and uses eval to evaluate the code. Somehow, it couldn't use the correct environment for the evaluation. Therefore I slightly changed the code so that you can pass the environment as an argument to the function.
it still doesn't work to evaluate shiny code. Therefore, I generated a normal variable out of the reactive directly before the docx rendering and use this in the template
library(shiny)
library(WordR)
library(officer)
library(dplyr)
renderInlineCode_2 <- function (docxIn, docxOut, eval_envir = parent.frame(), debug = F)
{
if (debug) {
browser()
}
doc <- officer::read_docx(docxIn)
smm <- officer::docx_summary(doc)
styles <- officer::styles_info(doc)
regx <- "^[ ]*`r[ ](.*)`$"
smm$expr <- ifelse(grepl(regx, smm$text), sub(regx, "\\1",
smm$text), NA)
smm$values <- sapply(smm$expr, FUN = function(x) {
eval(parse(text = x), envir = eval_envir)
})
smm <- smm[!is.na(smm$expr), , drop = F]
i <- 3
for (i in seq_len(nrow(smm))) {
stylei <- switch(ifelse(is.na(smm$style_name[i]), "a",
"b"), a = NULL, b = styles$style_name[styles$style_id ==
paste0(styles$style_id[styles$style_name == smm$style_name[i] &
styles$style_type == "paragraph"], "Char")])
doc <- officer::cursor_reach(doc, keyword = paste0("\\Q",
smm$text[i], "\\E")) %>% officer::body_remove() %>%
officer::cursor_backward() %>% officer::slip_in_text(smm$values[i],
pos = "after", style = stylei)
}
print(doc, target = docxOut)
return(docxOut)
}
ui <- fluidPage(
selectInput('slt_input', 'name', choices = c("god", 'devil')),
actionButton("btn_inline", 'inline')
)
server <- function(input, output, session) {
declared_user <- reactive({
input$slt_input
})
observeEvent(input$btn_inline,{
eval_user <- declared_user()
renderInlineCode_2("rprt_tmplt.docx", "rprt_out.docx")
})
}
shinyApp(ui, server)
In the template, use:
`r eval_user`
Edit
When thinking a bit more about it, I think in the original renderInlineCode function the parent.frame() of eval is renderInlineCode. Obviously, there the required objects are not included but in its parent.frame(). So you have to relay on R's scoping which doesn't work correctly here with shiny. I'm happy to get some more thorough explanations.
In /etc/shiny-server/shiny-server.conf I have an SSL configuration that looks like:
server {
# ...
ssl /etc/path/to/ssl-key.pem /etc/path/to/ssl.cert;
# ...
}
Now, from an R REPL on the server on which Shiny Server is running, I'm curious if there's a way to retrieve the configuration data from shiny-server.conf through any sort of (semi-) official API.
Something like:
# server.R
library(shiny)
shinyServer(function(input, output, session){
# ... ?
})
That will yield something to the effective of:
"ssl": ["/etc/path/to/ssl-key.pem", "/etc/path/to/ssl.cert"]
I don't think you can get access to that, to be honest, as it might be a security risk to allow apps (and therefore "regular users") to see configuration items. (It might include secrets for SAML/LDAP/... configuration for instance.)
Now I don't know that this answer will solve that problem, it might enable you to find what you need instead.
Note: I intentionally filter out several types of objects within session, as I've found that either they crash (they're complex compound objects, perhaps who-knows-what in them) or they're obviously just extraneous. One could possibly saveRDS this to a file and retrieve it from the server if you want to get more visibility to internals being filtered out.
library(shiny)
ui <- bootstrapPage(
h3("Parsed query string"),
verbatimTextOutput("queryText"),
h3("URL components"),
verbatimTextOutput("sessionText"),
h3("EnvVars"),
verbatimTextOutput("envvarText")
)
server <- function(input, output, session) {
# Parse the GET query string
output$queryText <- renderText({
query <- parseQueryString(session$clientData$url_search)
# Return a string with key-value pairs
paste(names(query), query, sep = "=", collapse=", ")
})
# Return the components of the URL in a string:
output$sessionText <- renderText({
cls <- sapply(session, function(a) class(a)[1])
nms <- names(cls[ cls %in% c("list", "character", "numeric", "integer", "NULL", "logical", "environment") ])
nms <- setdiff(nms, ".__enclos_env__")
paste(
capture.output(
str(
sapply(nms,
function(sessnm) {
if (inherits(session[[sessnm]], c("environment", "reactivevalues"))) {
sapply(names(session[[sessnm]]), function(nm) session[[sessnm]][[nm]], simplify = FALSE)
} else if (inherits(session[[sessnm]], c("character", "numeric", "integer"))) {
session[[sessnm]]
} else class(session[[sessnm]])
}, simplify = FALSE),
nchar.max = 1e5,
vec.len = 1e5
)
),
collapse = "\n"
)
})
# Dump the environment variables
output$envvarText <- renderText({
paste(
capture.output(
str(as.list(Sys.getenv()))
),
collapse = "\n"
)
})
}
shinyApp(ui, server)
This renders something like this (with some privacy blocked out, and fuzzy in general since, well, your results my differ depending on your specific server.
This is on RStudio Connect v1.8.2, hosted on Ubuntu 16.04. The authentication is via SAML; other auth methods might have slightly different (more or less) fields.
I have a group of variables that are used as id's on html elements with matching functions (conveniently named varname.helper()) that I would like to be called whenever an event is triggered on the respective html element.
I tried the following:
server <- function(input, output, session) {
observables <- c("foo1", "foo2", "foo3") # they are obviously much more than 3 vars...
observables %>% walk(function(x) {
observeEvent(quo(!!sym(paste0("input$", x))), quo(!!sym(paste0(x, ".helper"))(input)), handler.quoted=TRUE)
}
But it didn't work. Any ideas?
Your problem starts here. Tidy evaluation is not the optimal way to solve this.
observeEvent(quo(!!sym(paste0("input$", x))),
quo(!!sym(paste0(x, ".helper"))(input)), handler.quoted=TRUE)
You want (right?) to get input$foo1 and foo1.helper. With your code, the end result is this cluster of quos, syms and exclamation marks.
First of all, if all your helper variables are doing the same thing, why do you create lots of separate variables called foo1.helper? It would make more sense to put them in a list, so you can use any kind of looping/mapping to make life easier for you:
helpers <- list(foo1 = whatever..., foo2 = whatever...)
Next,
quo(!!sym(paste0("input$", x)))
gives you a rather complex object with a specific use case. Rather than using $, you better use the double bracket selection:
input[[x]]
This lets you select an item from a list based on its name, using a character variable x. These are easier to work with. The $ syntax is just sugar and doesn't let you use character values easily.
To sum up:
observeEvent(input[[x]], quote(helpers[[x]](input)), handler.quoted = TRUE)
Here's a short example on how to fit these things in your code. Note that you have to use purrr::walk here, as you can't use a for loop. A for loop doesn't work well together with the specific way observers etc are registered by the internals of shiny.
So your code would become:
library(shiny)
library(purrr)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
actionButton("foo1", "Foo 1"),
actionButton("foo2", "Foo 2")
),
"Nothing here"
)
)
server <- function(input, output) {
helpers <- list(foo1 = quote(cat("foo 1; ")), foo2 = quote(cat("foo 2; ")))
purrr::walk(c("foo1", "foo2"), ~ observeEvent(input[[.x]],
helpers[[.x]], handler.quoted = TRUE))
}
shinyApp(ui = ui, server = server)
I'm getting this error when I run below code, can anyone please tell how to overcome this error.
Below is the code in which mydata is the main data set and I have created a shiny dashboard using the below code.
I tried to make one of the column as URL , but its showing error as in title.
And I tried giving data()$IFX_USERNAME as in his is a very common error in shiny apps. This most typically appears when you create an object such as a list, data.frame or vector using the reactive() function – that is, your object reacts to some kind of input. If you do this, when you refer to your object afterwards, you must include parentheses.
For example, let’s say you make a reactive data.frame like so:
MyDF<-reactive({ code that makes a data.frame with a column called “X” })
If you then wish to refer to the data.frame and you call it MyDF or MyDF$X you will get the error. Instead it should be MyDF() or MyDF()$X You need to use this naming convention with any object you create using reactive(), even then its showing the same error
library("shiny")
library("datasets")
library("DT")
library("shinyBS")
library(tidyr)
lapply( dbListConnections( dbDriver( drv = "MySQL")), dbDisconnect)
#connecting to database
dbListTables(mydb)
dbListFields(mydb, 'DL_COMMUNITY')
rs = dbSendQuery(mydb, "select * from DL_COMMUNITY")
mydatabase=fetch(rs)
setDT(mydatabase)
colnames(mydatabase)
header <- dashboardHeader()
ui = shinyUI(fluidPage(
DT::dataTableOutput("mtcarsTable"),
bsModal("mtCarsModal", "My Modal", "",dataTableOutput('mytext'), size = "large")
))
on_click_js = "
Shiny.onInputChange('mydata', '%s');
$('#mtCarsModal').modal('show')
"
on_click_js1 = "
Shiny.onInputChange('mydata', '%s');
$('#mtcarsTable').modal('show')
"
convert_to_link = function(x) {
as.character(tags$a(href = "#", onclick = sprintf(on_click_js,x), x))
}
convert_to_link1 = function(x) {
as.character(tags$a(href = "#", onclick = sprintf(on_click_js1,x), x))
}
shinyApp(
ui = ui,
server = function(input, output, session) {
mtcarsLinked <- reactive({
mydatabase$IFX_USERNAME <- sapply(
mydatabase$IFX_USERNAME,convert_to_link)
return(mydatabase)
})
**linked <- reactive({
myd$TEAM_MEMBERS <- sapply(
myd$TEAM_MEMBERS,convert_to_link1)
return(myd)
})**
output$mtcarsTable <- DT::renderDataTable({
DT::datatable(mtcarsLinked(),
class = 'compact',
escape = FALSE, selection='none'
)
})
output$mytext = DT::renderDataTable({
#userQuery=paste("select PROJECT,COMMENT from DL_COMMUNITY where IFX_USERNAME = '",user,"'",sep="")
#rs = dbSendQuery(mysqlCon,userQuery)
userQuery=paste("SELECT *
from Heatmap.DL_PROJECT where CONCAT(',', TEAM_MEMBERS, ',') like '%,sa,%'
or PROJECT_OWNER like '%,sa,%'
or PROJECT_LEAD like '%,sa,%'")
rs = dbSendQuery(mydb,userQuery)
myd=fetch(rs,n=-1)
myd<-data.frame(myd)
myd$TEAM_MEMBERS<- as.list(strsplit(myd$TEAM_MEMBERS, ","))
#myd<-myd %>%
#mutate(TEAM_MEMBERS = strsplit(as.character(TEAM_MEMBERS), ",")) %>%
#unnest(TEAM_MEMBERS)
#setDT(myd)
#hello <- input$mydata
#myd<-mydatabase[mydatabase$IFX_USERNAME==input$mydata,]
#myd1<-t(myd)
DT::datatable(linked(),
class='compact',
escape = FALSE,selection = 'none')
})
}
)
First, always use my_reactive() when you call a reactive function e.g. my_reactive.
Second, the object of type closure not subsettable usually means that the object you want to subset (here with $) cannot be found. You are not having the object not found error because you gave it a name already known to R.
As in the example of jogo, the same error occurs when trying to subset mean. mean is an object in R so it exists and R will not return object not found but it is a function and you cannot subset from it hence the error object is not subsettable.
Compare the results of the following lines of code.
mean[1]
mean <- c(1, 3)
mean[1]
Also note that R can still use mean to perform the mean of a numeric vector as it knows when to look for a function or for something else. But it is strongly advised not to do that. You should always properly name your objects with meaningful names.