Nothing
#' Interactive Plotting for Registration Objects
#'
#' Produces an interactive plot illustrating functional data before and after registration.
#' Our registration method uses FPCA, the FPCA is plotted as well.
#'
#' @param obj registration object to be plotted.
#' @param xlab x axis label
#' @param ylab y axis label
#' @param title plot title
#' @param thin_data If TRUE data is thinned for each subject to make plotting faster. Defaults to FALSE.
#' @param ... additional arguments passed to plotting functions
#'
#' @author Julia Wrobel \email{julia.wrobel@@cuanschutz.edu}
#'
#' @seealso \code{\link{plot_shiny}}
#' @importFrom gridExtra grid.arrange
#' @importFrom plotly plot_ly event_data layout add_trace
#'
#' @export
#' @return No object is returned. This function takes in objects of class 'registration' and outputs a shiny application for that object.
#'
plot_shiny.registration = function(obj, xlab = "", ylab="", title = "", thin_data = FALSE, ...){
fpca.obj <- obj$fpca_obj
## NULLify global values called in ggplot
iteration = value = tstar = t_hat = index = pop_mean = Y.hat = yhat_inv_link = NULL
## establish inverse link function for plotting
inv_link = createInvLink(family <- fpca.obj$family)
## data management. Probably should think about generalizing this to other distributions.
Y = obj$Y
Y = mutate(Y, pop_mean = rep(inv_link(fpca.obj$mu), length.out = dim(Y)[1]),
Y.hat = fpca.obj$Yhat$value,
yhat_inv_link = inv_link(Y.hat))
if(thin_data){
Y = thin_functional_data(Y)
}
################################
## code for processing tabs
################################
#### registration
## curves
curves.help =if(obj$family == "gaussian"){
paste0("Unregistered (left) and registered (right) data from the ", obj$family, " exponential family.
Each curve is a subject.")
}else{
paste0("Unregistered (left) and registered data (right) from the ", obj$family, " exponential family.
Each row is a subject. Light and dark blue represent values of 0 and 1, respectively.")
}
## warps
warp.help1 = "Plot shows warping functions for all subjects; click on a specific curve to select a subject."
warp.help2 = "Plot shows observed data and fitted values for selected subject.
Green curve is population mean.
If no subjects are selected then first subject in dataset is shown."
#### fpca
# muPC plot
muPC.help = "Solid black line indicates population mean. For the FPC selected below, blue and red lines
indicate the population mean +/- the FPC times 2 SDs of the associated score distribution."
muPC.call = as.list(NA)
muPC.call[[1]] = selectInput(inputId = "PCchoice", label = ("Select FPC"), choices = 1:fpca.obj$npc, selected = 1)
## add y-axis scale input if family is not gaussian
if (!(is.null(fpca.obj$family) || fpca.obj$family == "gaussian")) {
muPC.call[[2]] = selectInput("muPC_scale", label = ("Select Y-axis Scale"), choices = c("Natural", "Response"), selected = "Natural")
}
# subject fits plot
subjects.help = "Plot shows observed data and fitted values for the subject selected below."
subjects.call = eval(call("selectInput", inputId = "subject", label = ("Select Subject"),
choices = unique(Y$id), selected = unique(Y$id)[1]))
# scoreplot (need to edit this in both versions)
scoredata = as.data.frame(fpca.obj$scores)
colnames(scoredata) = c(paste0("PC", 1:fpca.obj$npc))
scoredata = mutate(scoredata, id = unique(Y$id))
score.help1 = "Plot shows observed score scatterplot for first and second FPC; click on the scatterplot to select a subject."
score.help2 = "Plot shows observed data and fitted values for selected subject.
Green curve is population mean."
#################################
## App
#################################
shinyApp(
#################################
## UI
#################################
ui = navbarPage(title = strong(style = "color: #ACD6FF; padding: 0px 0px 10px 10px; opacity: 0.95; ", "Registration Plot"),
windowTitle = "refund.shiny", collapsible = FALSE, id = "nav", inverse = TRUE, header = NULL,
##### start tabs
tabPanel("registration", icon = icon("transfer", lib = "glyphicon"),
tabsetPanel(
tabPanelModuleUI("curves", tabTitle = "registered curves", helperText = curves.help),
tabPanelModuleUI("warps", tabTitle = "warping functions", helperText = warp.help1,
twoPlots = TRUE, is.plotly = TRUE, helperText2 = warp.help2)
)
),
tabPanel("fpca", icon = icon("stats", lib = "glyphicon"),
tabsetPanel(
tabPanelModuleUI("muPC", tabTitle = "Mean +/- FPCs", icon("stats", lib = "glyphicon"),
calls = muPC.call, helperText = muPC.help ),
tabPanelModuleUI("subjects",tabTitle = "Subject Fits", icon = icon("user"), calls = subjects.call,
helperText = subjects.help ),
tabPanelModuleUI("scoreplots",tabTitle = "Score Scatterplot", icon = icon("binoculars"), calls = NULL,
helperText = score.help1, twoPlots = TRUE, helperText2 = score.help2, is.plotly = TRUE)
)
) # end tabPanel
),
#################################
## Server
#################################
server = function(input, output){
#################################
## Code for curves plot
#################################
plotInputCurves <- reactive({
if(family == "binomial"){
curvesPlots = registerLasagna(Y)
grid.arrange(curvesPlots[[1]],curvesPlots[[2]], ncol = 2)
}else if(family == "gaussian"){
unreg = ggplot(Y, aes(x = tstar, y = value, group = id)) +
geom_path(alpha = .25) + theme_bw() +
labs(x = "t_star", y = "Prob(Y = 1)")
reg = ggplot(Y, aes(x = t_hat, y = value, group = id)) +
geom_path(alpha = .25) + theme_bw() +
labs(x = "t_hat", y = "Prob(Y = 1)")
grid.arrange(unreg, reg, ncol = 2)
}else{
stop("Package currently handles only 'binomial' or 'gaussian' families.")
}
})
callModule(tabPanelModule, "curves", plotObject = plotInputCurves, plotName = "curves", is.grid = TRUE)
#################################
## Code for plot of warping functions
#################################
plotInputWarps <- reactive({
key = Y$id
p = plot_ly(data = group_by(Y, id), x = ~t_hat, y = ~tstar, type = "scatter",
mode = 'lines', alpha = 0.5, source = "timewarps", key = ~key,
hoverinfo = 'text', text = ~paste('Id: ', id)) %>% layout(dragmode = "select")
p$elementId <- NULL
p
})
# for selected subjects plot observed data and fitted value
plotInputWarpSelect <- reactive({
clicked <- event_data("plotly_click", source = "timewarps")
if(!is.null(clicked)){
Y.clicked = filter(Y, id %in% clicked$key)
p = plot_ly(data = group_by(Y.clicked, id), x = ~t_hat, y = ~value, type = "scatter",
alpha = 0.25, mode = 'markers') %>%
add_trace(y = ~yhat_inv_link, mode = 'lines') %>%
add_trace(x = ~tstar, y = ~pop_mean, mode = 'lines') %>%
layout(dragmode = "select", showlegend = FALSE)
p$elementId <- NULL
p
}else{
p = plot_ly(data = filter(Y, id == first(Y$id)), x = ~t_hat, y = ~value,
type = "scatter",
alpha = 0.25, mode = 'markers') %>%
add_trace(y = ~yhat_inv_link, mode = 'lines') %>%
add_trace(x = ~tstar, y = ~pop_mean, mode = 'lines') %>%
layout(dragmode = "select", showlegend = FALSE)
p$elementId <- NULL
p
}
})
callModule(tabPanelModule, "warps", plotObject = plotInputWarps, plotName = "warps",
plotObject2 = plotInputWarpSelect, is.plotly = TRUE)
#################################
## Code for plot of fpca mean +/- PCs
#################################
plotInputMuPC <- reactive({
PCchoice = as.numeric(input$PCchoice)
if (!(is.null(fpca.obj$family) || fpca.obj$family == "gaussian") && input[["muPC_scale"]] == "Response") {
response_scale = TRUE
}else{
response_scale = FALSE
}
p1 <- make_muPC(fpca.obj, PCchoice, response_scale)
})
callModule(tabPanelModule, "muPC", plotObject = plotInputMuPC, plotName = "muPC")
#################################
## Code for fpca subject plots
#################################
plotInputSubject <- reactive({
subjectnum = as.numeric(input$subject)
Y_sub = filter(Y, id == subjectnum)
p4 = ggplot(Y_sub, aes(index, pop_mean)) +
geom_line(lwd = 0.5, color = "gray") +
geom_line(aes(y = yhat_inv_link), size = 1, color = "cornflowerblue") +
geom_point(aes(y = value), color = "blue", alpha = 1/3) +
theme_bw() + xlab(xlab) + ylab(ylab)
})
callModule(tabPanelModule, "subjects", plotObject = plotInputSubject, plotName = "subjects")
#################################
## Code for fpca score plots
#################################
## score plots
if(fpca.obj$npc == 1){scoredata$PC2 = scoredata$PC1}
plotInputScore <- reactive({
key = scoredata$id
p = plot_ly(data = scoredata, x = ~PC1, y = ~PC2, type = "scatter",
mode = 'markers', source = "scoreplot", key = ~key,
hoverinfo = 'text', text = ~paste('Id: ', id)) %>%
layout(dragmode = "select")
p$elementId <- NULL
p
})
plotInputScoreSelect <- reactive({
clicked <- event_data("plotly_click", source = "scoreplot")
if(!is.null(clicked)){
Y.clicked = filter(Y, id %in% clicked$key)
p = plot_ly(data = group_by(Y.clicked, id), x = ~t_hat, y = ~value, type = "scatter",
alpha = 0.25, mode = 'markers') %>%
add_trace(y = ~yhat_inv_link, mode = 'lines') %>%
add_trace(x = ~tstar, y = ~pop_mean, mode = 'lines') %>%
layout(dragmode = "select", showlegend = FALSE)
p$elementId <- NULL
p
}else{
p = plot_ly(data = filter(Y, id == first(Y$id)), x = ~t_hat,
y = ~value, type = "scatter",
alpha = 0.25, mode = 'markers') %>%
add_trace(y = ~yhat_inv_link, mode = 'lines') %>%
add_trace(x = ~tstar, y = ~pop_mean, mode = 'lines') %>%
layout(dragmode = "select", showlegend = FALSE)
p$elementId <- NULL
p
}
})
callModule(tabPanelModule, "scoreplots", plotObject = plotInputScore,
plotObject2 = plotInputScoreSelect, is.plotly = TRUE)
} # end server
) # end shiny app
} # end overall funtion
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.