ceplot.shiny <-
function (data, model, response = NULL, S = NULL, C = NULL, sigma = NULL, lambda
= NULL, distance = "euclidean", cex.axis = NULL, cex.lab = NULL, tck = NULL,
view3d = FALSE, Corder = "default", conf = FALSE, separate = TRUE,
select.colour = "blue", select.cex = 1, select.lwd = 2, select.type =
"minimal", probs = FALSE, col = "black", pch = 1, residuals = FALSE, xc.cond =
NULL, packages = NULL, xsplotpar = NULL, modelpar = NULL, xcplotpar = NULL)
{
## Check for shiny package, and stop if not installed
if(!requireNamespace("shiny", quietly = TRUE))
stop("requires package 'shiny'")
else if (!exists("runApp")) attachNamespace("shiny")
## Set up the initial section
xc.cond <- if (is.null(xc.cond))
data[1L, !colnames(data) %in% c(S, response), drop = FALSE]
else xc.cond
#data.frame(lapply(data[, !colnames(data) %in% c(S, response)], mode1))
## Set some variables and the similarityweight function
uniqC <- unique(unlist(C))
xcplots <- list()
plotlegend <- length(S) == 2
n.selector.cols <- ceiling(length(C) / 4L)
selector.colwidth <- 2
height <- 8
col <- rep(col, length.out = nrow(data))
need3d <- identical(length(S), 2L) && all(vapply(data[, S, drop = FALSE],
is.numeric, logical(1L))) && is.numeric(data[, response[1]])
seqC <- seq_along(C)
lenC <- length(C)
wd <- getwd()
vwfun <- .similarityweight(xc = data[, uniqC, drop = FALSE])
## These are the packages required to call predict on all models in 'model'
## If not supplied, all packages attached to the search path at the time of
## calling ceplot are recorded.
packages <- if (is.null(packages))
rev(gsub("package:", "", grep("package:", search(), value = TRUE)))
else packages
## Function to create the shiny ui.R file. 'deploy' switch removes certain
## elements when deploying the application.
ui <- function (deploy = FALSE)
{
paste0('
## This ui.R file was created by condvis:::ceplot.shiny
library(shiny)
load("app.Rdata")
h <- "170px"
hS <- "350px"
basicPage(
column(4,
if (need3d) {
tabsetPanel(
tabPanel("Contour",
plotOutput("plotS", height = hS, width = hS),
value = 1),
tabPanel("Perspective",
plotOutput("plotS3D", height = hS, width = hS),
value = 2),
id = "tab"
)
} else plotOutput("plotS", height = hS, width = hS),
conditionalPanel(condition = "input.tab == 2",
numericInput("phi", "Vertical rotation: ", 20, -180, 180),
numericInput("theta", "Horizontal rotation: ", 45, -180, 180)),
sliderInput("threshold", "Distance threshold: ", 0.01, 5, step =
0.01, value = if (is.null(sigma)) 1 else sigma),
radioButtons("distance", "Distance function type:", c("euclidean",
"maxnorm")),
hr(),
downloadButton("download", "Download snapshot (pdf)")',
if (!deploy) ',\n actionButton("openDeploy", "Deploy app"),
br(),
conditionalPanel(condition = "input.openDeploy % 2 == 1",
radioButtons("deployLocation", "", c("to web via rsconnect",
"to working directory")),
textInput("appName", label = "Application name (valid directory name)"),
actionButton("deployButton", "Deploy app"),
br(), br(),
p("Help configuring", a("rsconnect", href =
"http://shiny.rstudio.com/articles/shinyapps.html", target = "_blank")
)
)','
),
', if (identical(length(S), 2L)) 'column(1,
plotOutput("legend", height = hS, width = "100px")
),','
column(7,
fluidRow(helpText("Condition selectors")),
column(4,
plotOutput("plot1", click = "plot_click1", height = h, width = h),
plotOutput("plot2", click = "plot_click2", height = h, width = h),
plotOutput("plot3", click = "plot_click3", height = h, width = h),
tableOutput("info")
)
', if (lenC > 3){',column(4,
plotOutput("plot4", click = "plot_click4", height = h, width = h),
plotOutput("plot5", click = "plot_click5", height = h, width = h),
plotOutput("plot6", click = "plot_click6", height = h, width = h)
)'},
if (lenC > 6){',column(4,
plotOutput("plot7", click = "plot_click4", height = h, width = h),
plotOutput("plot8", click = "plot_click5", height = h, width = h),
plotOutput("plot9", click = "plot_click6", height = h, width = h)
)'}, '
)
)
')
}
## Function to create the shiny server.R file. 'deploy' switch removes certain
## elements when deploying the application.
server <- function (deploy = FALSE){
paste(
' ## This server.R file was created by condvis:::ceplot.shiny
library(condvis)
library(shiny)
## Include the packages required for the application. If these have not been
## specified, the package list will be inferred from the search path at the
## time ceplot was called.
\n ',
paste(paste0("library(", packages, ")"), collapse = "\n ")
,'
## Shiny server
shinyServer(function (input, output)
{
## Load the objects that were in the environment of the ceplot call.
#load("app.Rdata")
## Reactive value for the current condition/section
rv <- reactiveValues(xc.cond = xc.cond)
## Event listeners for mouseclicks on plots
',
paste('
observeEvent({input$plot_click', seqC,'}, {
rv$xc.cond[, xcplots[[', seqC,']]$name] <<- condvis:::update.xcplot(
xcplots[[', seqC,']], xclick = input$plot_click', seqC,'$x, yclick =
input$plot_click', seqC,'$y, user = TRUE, draw = FALSE)$xc.cond.old
})
', sep = '', collapse = '\n'),
'
## Do condition selector plots.
',
paste("
output$plot", seqC, " <- renderPlot({
i <- ", seqC, "
xcplots[[i]] <<- plotxc(xc = data[, C[[i]]], xc.cond = rv$xc.cond[1L,
C[[i]]], name = colnames(data[, C[[i]], drop = FALSE]), trim =
xcplotpar$trim, select.colour = select.colour, select.cex = select.cex,
hist2d = xcplotpar$hist2d, fullbin = xcplotpar$fullbin)
})"
, sep = "", collapse = "\n"), '
## Next do the section visualisation.
vw <- NULL
output$plotS <- renderPlot({
vw <<- vwfun(xc.cond = rv$xc.cond, sigma = input$threshold, distance =
input$distance, lambda = lambda)
xsplot <<- condvis:::plotxs(xs = data[, S, drop = FALSE], data[, response
, drop = FALSE], xc.cond = rv$xc.cond, model = model, col = col, weights
= vw$k, view3d = FALSE, conf = conf, probs = probs, pch = pch,
model.colour = modelpar$col, model.lwd = modelpar$lwd, model.lty =
modelpar$lty, main = xsplotpar$main, xlim = xsplotpar$xlim, ylim =
xsplotpar$ylim)
})
## Section visualisation for 3-D perspective mesh.
output$plotS3D <- renderPlot({
vw <<- vwfun(xc.cond = rv$xc.cond, sigma = input$threshold, distance =
input$distance, lambda = lambda)
xsplot <<- condvis:::plotxs(xs = data[, S, drop = FALSE], data[, response
, drop = FALSE], xc.cond = rv$xc.cond, model = model, col = col,
weights = vw$k, view3d = TRUE, conf = conf, probs = probs, pch = pch,
model.colour = modelpar$col, model.lwd = modelpar$lwd, model.lty =
modelpar$lty, main = xsplotpar$main, xlim = xsplotpar$xlim, ylim =
xsplotpar$ylim)
})
## Legend for section
output$legend <- renderPlot({
condvis:::xslegend(y = data[, response[1]], name = response[1])
})
## Give a basic table showing the section/condition values
output$info <- renderTable({
structure(rv$xc.cond, row.names = "section")
})
## Allow the user to download a snapshot of the current visualisation
output$download <- downloadHandler(filename = function() { paste0(
"condvis-download-", condvis:::timestamp1(), ".pdf")}, {
function(file){
n.selector.cols <- ceiling(length(C) / 4L)
select.colwidth <- max(min(0.18 * n.selector.cols, 0.45), 0.2)
width <- 8.5 + 2 * n.selector.cols
pdf(file = file, width = width, height = 8)
condvis:::ceplot.static(data = data, model = model, response = response,
S = S, C = C, cex.axis = cex.axis, cex.lab = cex.lab, tck = tck,
xc.cond = rv$xc.cond, weights = vw$k, col = col, select.colour =
select.colour, select.cex = select.cex, conf = conf, probs = probs)
dev.off()
}
})',
if (!deploy){'
## Code after here relates to deploying the current application, and will
## not be present in a deployed application.
observeEvent(input$deployButton, {
folderpath <- if (input$deployLocation == "to working directory")
wd
else tempdir()
appname <- if (input$appName == "")
"condvis-shinyapp"
else input$appName
deploy.path <- paste0(folderpath, "/", appname)
dir.create(deploy.path, showWarnings = FALSE)
write(ui(deploy = TRUE), file = paste0(deploy.path, "/ui.R"))
write(server(deploy = TRUE), file = paste0(deploy.path, "/server.R"))
file.copy(from = paste0(app.path, "/app.Rdata"), to = paste0(deploy.path,
"/app.Rdata"), overwrite = TRUE)
file.copy(from = paste0(app.path, "/global.R"), to = paste0(deploy.path,
"/global.R"), overwrite = TRUE)
if (input$deployLocation == "to web via rsconnect"){
if (!requireNamespace("rsconnect", quietly = TRUE))
stop("requires package \'rsconnect\'")
else if (!exists("deployApp")) attachNamespace("rsconnect")
rsconnect::deployApp(deploy.path)
}
})'}, '
})
')
}
## Create a temporary directory to store the application files (including a
## snapshot of the objects in this environment in "app.Rdata") and run the
## application
app.path <- paste0(tempdir(), "/condvis-shinyapp-temp")
dir.create(app.path, showWarnings = FALSE)
write(ui(), file = paste0(app.path, "/ui.R"))
write(server(), file = paste0(app.path, "/server.R"))
write("load(\"app.Rdata\", envir=.GlobalEnv)\n", file = paste0(app.path,
"/global.R"))
save(list = union(ls(), ls(.GlobalEnv)), file = paste0(app.path, "/app.Rdata")
)
shiny::runApp(appDir = app.path)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.