Nothing
#' Visualize time intervals across subjects/parameters.
#' @param paramVar Character vector with variable of \code{data}
#' to represent in the y-axis.
#' @param paramLab (optional) String with label for \code{paramVar}.
#' @param paramVarSep (optional) String with separator used to combined \code{paramVar}
#' if multiple.
#' @param paramGroupVar (optional) Character vector with variable(s) to group/order
#' the \code{paramVar} elements in the y-axis.
#' @param timeStartVar String with variable with the start of the time interval.
#' @param timeStartLab (optional) String with label for \code{timeStartVar}.
#' @param timeEndVar String with variable with the end of the time interval.
#' @param timeEndLab (optional) String with label for \code{timeEndVar}.
#' @param timeStartShapeVar (optional) String with variable used for the shape
#' of the start of the time interval.
#' @param timeStartShapeLab (optional) String with label for \code{timeStartShapeVar}.
#' @param timeEndShapeVar (optional) String with variable used for the shape
#' of the end of the time interval.
#' @param timeEndShapeLab (optional) String with label for \code{timeEndShapeVar}.
#' @param shapePalette (optional) Character vector with shape palette for
#' \code{timeStartShapeVar} and \code{timeEndShapeVar}.
#' @param xLab,yLab (optional) String with labels for the x/y-axis.
#' @param alpha (optional) Numeric with transparency, 1 by default.
#' @inheritParams clinDataReview-common-args
#' @inheritParams tableClinData
#' @inherit scatterplotClinData return
#' @example inst/examples/timeProfileIntervalPlot-example.R
#' @author Laure Cougnaud
#' @family Clinical data visualization of individual profiles.
#' @import plotly
#' @importFrom clinUtils formatVarForPlotLabel getColorPalette getShapePalette
#' @importFrom crosstalk bscols filter_select
#' @importFrom plyr dlply
#' @export
timeProfileIntervalPlot <- function(data,
paramVar, paramLab = getLabelVar(paramVar, labelVars = labelVars),
paramVarSep = " - ",
paramGroupVar = NULL,
timeStartVar, timeStartLab = getLabelVar(timeStartVar, labelVars = labelVars),
timeEndVar, timeEndLab = getLabelVar(timeEndVar, labelVars = labelVars),
# shape
timeStartShapeVar = NULL, timeStartShapeLab = getLabelVar(timeStartShapeVar, labelVars = labelVars),
timeEndShapeVar = NULL, timeEndShapeLab = getLabelVar(timeEndShapeVar, labelVars = labelVars),
shapePalette = NULL,
# color
colorVar = NULL, colorLab = getLabelVar(colorVar, labelVars = labelVars),
colorPalette = NULL,
# transparency
alpha = 1,
# labels
yLab = NULL, #paste(paramLab, collapse = "\n"),
xLab = paste(c(timeStartLab, timeEndLab), collapse = " and "),
title = NULL,
subtitle = NULL, caption = NULL,
labelVars = NULL,
# interactivity:
width = 800, height = NULL,
hoverVars, hoverLab,
# path to subject-specific report
idVar = "USUBJID", idLab = getLabelVar(idVar, labelVars = labelVars),
pathVar = NULL, pathLab = getLabelVar(pathVar, labelVars = labelVars),
id = paste0("plotClinData", sample.int(n = 1000, size = 1)),
# selection
selectVars = NULL, selectLab = getLabelVar(selectVars, labelVars = labelVars),
# table
table = FALSE,
tableVars, tableLab,
tableButton = TRUE, tablePars = list(),
watermark = NULL,
verbose = FALSE){
# store input parameter values for further use
plotArgs <- c(as.list(environment()))
## Format data
# fill missing time:
# timeStartVar <- paste0(timeStartVar, "Plot")
# timeEndVarPlot <- paste0(timeEndVar, "Plot")
# data <- formatTimeInterval(
# data = data,
# timeStartVar = timeStartVar, timeEndVar = timeEndVar,
# timeStartVarNew = timeStartVar, timeEndVarNew = timeEndVarPlot,
# subjectVar = subjectVar,
# timeLim = timeLim, timeLimData = timeLimData,
# timeLimStartVar = timeLimStartVar, timeLimEndVar = timeLimEndVar
# )
# if(!all(data[, c(timeStartVar, timeEndVar)] == data[, c(timeStartVar, timeEndVarPlot)], na.rm = TRUE))
# stop("Issue of extraction of missing time.")
# concatenate variable(s) if multiple are specified
if(length(paramVar) > 1){
data$paramVar <- apply(data[, paramVar], 1, paste, collapse = paramVarSep)
}else{
data$paramVar <- data[, paramVar]
}
# include the selection variable in the y-axis as well
# to have range of the y axis reset to only contain selected parameters
if(!is.null(selectVars)){
data$yVar <- apply(data[, c(selectVars, "paramVar")], 1, paste, collapse = paramVarSep)
}else{
data$yVar <- data[, "paramVar"]
}
# order y-variable based on selection, grouping and parameter variables
data$yVar <- formatVarForPlotLabel(
data = data,
paramVar = "yVar", paramGroupVar = unique(c(selectVars, paramGroupVar, paramVar)),
width = 20
)
# in order to specify layout/yaxis/range
if(is.null(selectVars))
data$yVar <- as.numeric(data$yVar)
# variables used to uniquely identify a record
# between the table and the plot
# issue when key variable is too long in highlight_key
# so use row IDs
data$key <- as.character(seq_len(nrow(data)))
keyVar <- "key"
# To have correct symbols matching in plotly
# - shape variable must be factor
# - if multiple shape vars, each var should contain all levels
if(!is.null(timeStartShapeVar) | !is.null(timeEndShapeVar)){
getLevels <- function(x)
if(is.factor(x)) levels(x) else unique(x)
shapeLevels <- c(
if(!is.null(timeStartShapeVar)) getLevels(data[, timeStartShapeVar]),
if(!is.null(timeEndShapeVar)) getLevels(data[, timeEndShapeVar])
)
shapeLevels <- unique(shapeLevels)
if(!is.null(timeStartShapeVar))
data[, timeStartShapeVar] <- factor(data[, timeStartShapeVar], levels = shapeLevels)
if(!is.null(timeEndShapeVar))
data[, timeEndShapeVar] <- factor(data[, timeEndShapeVar], levels = shapeLevels)
}
# format data to: 'SharedData' object
if(missing(hoverVars)){
hoverVars <- c(paramVar,
timeStartVar, timeStartShapeVar, timeEndVar, timeEndShapeVar,
colorVar, selectVars
)
hoverLab <- c(
getLabelVar(var = paramVar, label = paramLab, labelVars = labelVars),
getLabelVar(var = timeStartVar, label = timeStartLab, labelVars = labelVars),
getLabelVar(var = timeEndVar, label = timeEndLab, labelVars = labelVars),
getLabelVar(var = colorVar, label = colorLab, labelVars = labelVars),
getLabelVar(var = timeStartShapeVar, label = timeStartShapeLab, labelVars = labelVars),
getLabelVar(var = timeEndShapeVar, label = timeEndShapeLab, labelVars = labelVars),
getLabelVar(var = selectVars, label = selectLab, labelVars = labelVars)
)
}else if(missing(hoverLab)){
hoverLab <- getLabelVar(hoverVars, labelVars = labelVars)
}
hoverVars <- unique(hoverVars);hoverLab <- hoverLab[hoverVars]
## Convert to SharedData
convertToSharedDataIntPlot <- function(data)
formatDataForPlotClinData(
data = data,
id = id,
keyVar = keyVar,
labelVars = labelVars,
hoverVars = hoverVars, hoverLab = hoverLab,
hoverByVar = c(selectVars, paramVar, timeStartVar, timeEndVar)
)
dataPlotSharedData <- convertToSharedDataIntPlot(data)
if(is.null(colorPalette)){
colorPaletteOpt <- getOption("clinDataReview.colors")
if(!is.null(colorVar)){
colorPalette <- getColorPalette(
x = data[, colorVar],
palette = colorPaletteOpt
)
}else colorPalette <- getColorPalette(n = 1, palette = colorPaletteOpt)
}
# extract y-values and corresponding labels
dimPlot <- getSizePlot(
width = width, height = height,
title = title,
subtitle = subtitle,
caption = caption,
xLab = xLab,
includeLegend = !is.null(colorVar),
legendPosition = "bottom",
# take the maximum plot height across selection groups
y = dlply(data, selectVars, function(x) droplevels(as.factor(x[, "paramVar"])))
)
width <- dimPlot[["width"]]
height <- dimPlot[["height"]]
pl <- plot_ly(width = width, height = height)
## markers for symbols
# always display symbols to:
# 1) have a hover (not possible in rectangle)
# 2) have a symbol when start and end is the same
if(!is.null(timeStartShapeVar) | !is.null(timeEndShapeVar)){
if(is.null(shapePalette)){
shapePalette <- getShapePalette(
x = shapeLevels,
palette = getOption("clinDataReview.shapes")
)
}else shapePalette <- shapePalette[shapeLevels]
}else shapePalette <- NULL
addMarkers <- function(p, showlegend = FALSE, ...){
add_markers(
data = dataPlotSharedData,
p = p,
y = varToFm("yVar"),
color = if(!is.null(colorVar)) varToFm(colorVar) else I(colorPalette),
colors = if(!is.null(colorVar)) colorPalette,
hovertemplate = varToFm("hover"),
showlegend = showlegend,
opacity = alpha,
...
)
}
pl <- addMarkers(
p = pl,
x = varToFm(timeStartVar),
symbol = if(!is.null(timeStartShapeVar)) varToFm(timeStartShapeVar),
symbols = if(!is.null(shapePalette)) I(shapePalette)
)
pl <- addMarkers(
p = pl,
x = varToFm(timeEndVar),
symbol = if(!is.null(timeEndShapeVar)) varToFm(timeEndShapeVar),
symbols = if(!is.null(shapePalette)) I(shapePalette)
)
# create legend only with color
# because plotly doesn't support multiple legend
if(!is.null(colorVar))
pl <- addMarkers(
p = pl, x = varToFm(timeStartVar),
showlegend = TRUE, visible = "legendonly"
)
## segments for time-interval
# plotly returns an error when no non-missing values in start/end time vars
# and 'crossed' segments if start value == end value
idxSegments <- which(
rowSums(is.na(data[, c(timeStartVar, timeEndVar)])) != length(c(timeStartVar, timeEndVar)) &
data[, timeStartVar] != data[, timeEndVar]
)
if(length(idxSegments) > 0){
dataPlotSharedDataSeg <- convertToSharedDataIntPlot(data = data[idxSegments, , drop = FALSE])
pl <- pl %>% add_segments(
data = dataPlotSharedDataSeg,
x = varToFm(timeStartVar),
xend = varToFm(timeEndVar),
y = varToFm("yVar"),
yend = varToFm("yVar"),
color = if(!is.null(colorVar)) varToFm(colorVar) else I(colorPalette),
colors = if(!is.null(colorVar)) colorPalette,
showlegend = FALSE,
opacity = alpha
)
}
# set layout
yData <- unique(data[order(data[, "yVar"]), c("yVar", "paramVar")])
pl <- layoutClinData(
p = pl,
title = title,
xLab = xLab,
yLab = yLab,
caption = caption,
subtitle = subtitle,
includeLegend = !is.null(colorVar),
legendPosition = "bottom",
width = width,
height = height,
watermark = watermark,
# extra params passed to plotly::layout
legend = list(title = list(text = colorLab)),
yaxis = c(
list(
showgrid = TRUE,
title = list(text = yLab),
type = "array",
tickvals = yData[, "yVar"],
ticktext = yData[, "paramVar"],
tickangle = 0
),
# reduce padding axis <-> plot & plot <-> title
if(is.null(selectVars))
list(range = c(0.5, nrow(yData)+0.5))
),
hovermode = "closest"
)
# specific formatting for clinical data
res <- formatPlotlyClinData(
data = data, pl = pl,
# extract patient profile based on the 'key' variable
# (not yVar because different records could be grouped in the same yVar)
# (should be included in the plot)
idVar = keyVar, pathVar = pathVar,
# extract ID from 'y' column in the plot output object directly
idVarPlot = "key", idFromDataPlot = TRUE,
# no label for patient prof filename because y is a numeric (not informative)
# labelVarPlot = "y",
id = id,
# selection
selectVars = selectVars, selectLab = selectLab,
labelVars = labelVars,
keyVar = keyVar,
verbose = verbose,
pathDownload = FALSE # open in new tab
)
# create associated table
if(table){
tableVars <- getPlotTableVars(
plotFunction = "timeProfileIntervalPlot",
plotArgs = plotArgs
)
tableLab <- attr(tableVars, "tableLab")
table <- tableClinData(
data = data,
keyVar = keyVar, idVar = idVar,
pathVar = pathVar, pathLab = pathLab,
tableVars = tableVars,
tableLab = tableLab,
tableButton = tableButton, tablePars = tablePars,
id = id,
labelVars = labelVars,
verbose = verbose
)
res <- c(
if(inherits(res, "plotly")){list(plot = res)}else{res},
list(table = table)
)
}
if(!inherits(res, "plotly"))
class(res) <- c("clinDataReview", class(res))
return(res)
}
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.