Last active
March 4, 2016 21:36
-
-
Save zross/adb1a0bfd2fb412e54e3 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
library(shiny) | |
source("junk_inputwrapper.R") | |
server <- function(input, output, session) { | |
input <- createInputWrapper(input) | |
output$plot <- renderUI({ | |
h <- input$height | |
w <- input$width | |
list( | |
tags$h3("Plot information"), | |
renderPlot({ | |
Sys.sleep(1) | |
plot(1:10, main=input$title, type=input$type) | |
rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col = sample(colors() ,1)) | |
print(paste(Sys.time(), "Inside plot")) | |
},res=90, height=exprToFunction(ifelse(is.null(h), 600, h)), | |
width=exprToFunction(ifelse(is.null(w), 600, w))) | |
) | |
}) | |
observe({ | |
updateNumericInput(session, "width", value = input$height) | |
invalidateInput(input, "width") | |
}) | |
observe({ | |
updateNumericInput(session, "title", value = paste("Width is", input$width)) | |
invalidateInput(input, "title") | |
}) | |
} | |
ui <- fluidPage( | |
tags$div(class="panel-body", | |
# if you change height without invalidateInput the print statement | |
# above prints three times | |
numericInput("height", "height", 300), | |
textInput("title", "Give a title", "This is my initital title"), | |
numericInput("width", "width", 300), | |
selectInput("type", "choose type", choices=c("p", "n", "s"), selected="s") | |
), | |
uiOutput("plot") | |
) | |
shinyApp(ui = ui, server = server) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# From Joe Cheng | |
#' Call `input <- createInputWrapper(input)` at the top of | |
#' your Shiny Server function. | |
createInputWrapper <- function(input) { | |
env <- new.env(parent = emptyenv()) | |
env$impl <- input | |
env$blacklist <- new.env(parent = emptyenv()) | |
structure( | |
env, | |
class = "inputWrapper" | |
) | |
} | |
`$.inputWrapper` <- function(x, name) { | |
realInput <- base::get("impl", x) | |
result <- realInput[[name]] | |
if (isTRUE(base::get("blacklist", x)[[name]])) { | |
req(FALSE) | |
} | |
result | |
} | |
`[[.inputwrapper` <- `$.inputWrapper` | |
#' Invalidate an input value, that is, mark it so that any future | |
#' attempts to read the value will result in a silent error being | |
#' thrown (equivalent to `req(FALSE)`). The value will exit the | |
#' invalidated state automatically the next time the client sends | |
#' a new value; or manually, with a call to restoreInput(). | |
invalidateInput <- function(input, name) { | |
force(input) | |
force(name) | |
firstRun <- TRUE | |
o <- observe({ | |
getDefaultReactiveDomain()$input[[name]] | |
if (firstRun) { | |
firstRun <<- FALSE | |
} else { | |
o$destroy() | |
restoreInput(input, name) | |
} | |
}, priority = 999999) | |
base::assign(name, TRUE, base::get("blacklist", input)) | |
} | |
#' Make an input value available for reading again. | |
restoreInput <- function(input, name) { | |
#cat("Restore ", name, "\n") | |
base::rm(list = name, envir = base::get("blacklist", input)) | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment