#' Called from V diagram R Markdown files.
#'
#' @param reportObject V diagram report data.
renderVDiagram <- function(reportObject) {
options(scipen = 8)
styles <- getVDiagramStyle()
measurements <- parseFieldMeasurementData(reportObject)
shifts <- parseRatingShiftsData(reportObject)
maxStage <- fetchMaxStage(reportObject)
validParam(maxStage, "maxStage")
minStage <- fetchMinStage(reportObject)
validParam(minStage, "minStage")
#Check if we have any measurements to plot, or if we have any shift data - If we don't, return NULL
if( (isEmptyOrBlank(measurements$measurementNumber) ) && (!hasEnoughVdiagramData(shifts)) ){
return(NULL)
}
vplot <- gsplot(mar = c(7, 3, 4, 2), yaxs = "r", xaxs = "r") %>%
points(NA, NA, axes = FALSE) %>%
view(ylab = styles$plot$ylab, xlab = styles$plot$xlab)
vplot <- do.call(grid, append(list(object = vplot), styles$grid))
# max./min. stage lines at top/bottom of plot
vplot <- do.call(abline, append(
list(object = vplot, a = maxStage), styles$maxStageLine
))
vplot <- do.call(abline, append(
list(object = vplot, a = minStage), styles$minStageLine
))
vplot <- addMeasurementsAndError(vplot, measurements, styles)
vplot <- addRatingShifts(vplot, shifts, styles)
vplot <- testCallouts(vplot, xlimits = xlim(vplot)$side.1)
ylims <- c(
min(c(ylim(vplot)$side.2, minStage)),
max(c(ylim(vplot)$side.2, maxStage))
)
xlims <- xlim(vplot)$side.1
y_seq <- pretty(ylims, shrink.sml = 20)
x_seq <- pretty(xlims, shrink.sml = 20)
vplot <- axis(vplot, side = 1, at = x_seq) %>%
axis(side=c(2,4), at = y_seq) %>%
view(side = 2, ylim = ylims)
return(vplot)
}
#' Has Enough Vdiagram Data
#' @description returns true if we have enough data to plot
#' @param shifts the data in this report
#' return true or false if enough data exists to render a meaningful plot
hasEnoughVdiagramData <- function(shifts) {
relevantShiftData <- unname(unlist(shifts[c("shiftId")]))
relevantShiftData <- relevantShiftData[which(!is.na(relevantShiftData))]
hasEnough <- !isEmptyOrBlank(relevantShiftData)
return(hasEnough)
}
#' Add Measurements and Errors
#' Given a gsplot object, will add measurements to the plot. Measurements points and errors styled differently if they are historical or not
#' @param vplot the gsplot object for the vdiagram
#' @param measurements measurements information
#' @param styles a list of styles to be used for styling the points
addMeasurementsAndError <- function(vplot, measurements, styles) {
histFlag <- measurements$histFlag
if (any(histFlag)){
# TODO replace with below when working
#error_bar(gsNew, x=1:3, y=c(3,1,2), x.low=c(.2,NA,.2), x.high=.2, col="red",lwd=3)
arrow_notNA <- intersect(which(!is.na(measurements$minShift)), which(!is.na(measurements$maxShift)))
arrow_notNA_hist <- intersect(arrow_notNA, which(histFlag))
minShift <- measurements$minShift[arrow_notNA_hist]
maxShift <- measurements$maxShift[arrow_notNA_hist]
obsGage <- measurements$obsGage[arrow_notNA_hist]
if (!isEmptyOrBlank(maxShift) || !isEmptyOrBlank(minShift) || !isEmptyOrBlank(obsGage)) {
vplot <- do.call(arrows, append(list(object=vplot, x0=minShift, y0=obsGage,
x1=maxShift, y1=obsGage), styles$err_lines_historic))
}
point_notNA_hist <- intersect(which(!is.na(measurements$obsShift)), which(histFlag))
x <- measurements$obsShift[point_notNA_hist]
y <- measurements$obsGage[point_notNA_hist]
if (!isEmptyOrBlank(x) || !isEmptyOrBlank(y)) {
vplot <- do.call(points, append(list(object=vplot, x=x, y=y),
styles$err_points_historic))
}
}
if (any(!measurements$histFlag)){
arrow_notNA <- intersect(which(!is.na(measurements$minShift)), which(!is.na(measurements$maxShift)))
arrow_notNA_nothist <- intersect(arrow_notNA, which(!histFlag))
minShift <- measurements$minShift[arrow_notNA_nothist]
maxShift <- measurements$maxShift[arrow_notNA_nothist]
obsGage <- measurements$obsGage[arrow_notNA_nothist]
if (!isEmptyOrBlank(maxShift) || !isEmptyOrBlank(minShift) || !isEmptyOrBlank(obsGage)) {
vplot <- do.call(arrows, append(list(object=vplot,x0=minShift, y0=obsGage,
x1=maxShift, y1=obsGage), styles$err_lines))
}
point_notNA_nothist <- intersect(which(!is.na(measurements$obsShift)), which(!histFlag))
x <- measurements$obsShift[point_notNA_nothist]
y <- measurements$obsGage[point_notNA_nothist]
obsIDs <- measurements$obsIDs[point_notNA_nothist]
measurementNumber <- measurements$measurementNumber[point_notNA_nothist]
publish <- measurements$publish[point_notNA_nothist]
if (!isEmptyOrBlank(x) || !isEmptyOrBlank(y) || !isEmptyOrBlank(obsIDs) || !isEmptyOrBlank(measurementNumber)) {
for (i in 1:length(x)) {
if(publish[i]=="FALSE") {
vplot <- do.call(points, append(list(object=vplot,x=x[i], y=y[i],
col = as.numeric(obsIDs[i])+1), styles$err_points))
vplot <- do.call(callouts, list(object=vplot, x = x[i], y = y[i], labels=measurementNumber[i], col="blue"))
} else {
vplot <- do.call(points, append(list(object=vplot,x=x[i], y=y[i],
col = as.numeric(obsIDs[i])+1), styles$err_points))
vplot <- do.call(callouts, list(object=vplot, x = x[i], y = y[i], labels=measurementNumber[i], col="black"))
}
}
}
}
return(vplot)
}
#' Add Rating Shifts
#' Given a gsplot object, will add rating shift points, arrows, lines with callouts to the plot (The "V's")
#' @param vplot the gsplot object for the vdiagram
#' @param shifts shift information
#' @param styles a list of styles to be used for styling the points/callouts
#' @importFrom utils head
#' @importFrom utils tail
addRatingShifts <- function(vplot, shifts, styles) {
for (id in unique(shifts[['shiftId']])) {
# if there are multiple shifts for the same ID, only want to plot the first occurrence
# otherwise you get overplotting and it looks bad
i <- which(shifts[['shiftId']] == id)[1]
x <- shifts[['shiftPoints']][[i]]
y <- shifts[['stagePoints']][[i]]
ID <- as.numeric(shifts[['shiftId']][i])
vplot <- do.call(callouts, list(object=vplot, x=x[2], y=y[2], labels=ID, cex = styles$rating_shift$callout_cex))
vplot <- do.call(callouts, list(object=vplot, x=head(x,1), y=head(y,1), labels=ID, cex = styles$rating_shift$callout_cex))
vplot <- do.call(callouts, list(object=vplot, x=tail(x,1), y=tail(y,1), labels=ID, cex = styles$rating_shift$callout_cex))
if (!is.null(styles$rating_shift$extendStageBy)){
xlength = length(x)
vplot <- do.call(arrows, append(list(object=vplot, x0=x[xlength], y0=tail(y,1) + styles$rating_shift$extendStageBy,
x1=x[xlength], y1=y[xlength], col=ID), styles$rating_shift$from_segment))
vplot <- do.call(arrows, append(list(object=vplot, x0=x[1], y0=y[1], x1=x[1], y1=y[1] - styles$rating_shift$extendStageBy,
col=ID), styles$rating_shift$to_segment))
}
vplot <- do.call(lines, append(list(object=vplot, x=x, y=y, type="o", col=ID), styles$rating_shift$shift_segment))
}
return(vplot)
}
#' Create V Diagram Table
#'
#' @param reportObject A list of properly formatted V diagram report data.
#' @return A string properly formatted for HTML.
#' @importFrom knitr kable
#' @export
vdiagramTable <- function(reportObject){
shifts <- parseRatingShiftsData(reportObject)
if(hasEnoughVdiagramData(shifts)){
startTime <- shifts[["startTime"]]
numOfShifts <- shifts[["numOfShifts"]]
df <- data.frame('Curve' = c(),
'Rating' = c(),
'Date'= c(),
'Points' = c(),
'Comments' = c(), check.names = F)
for (i in 1:numOfShifts){
time <- flexibleTimeParse(startTime[i], fetchReportMetadataField(reportObject, 'timezone'))
nPoints <- length(shifts[["stagePoints"]][[i]])
points <- vector('numeric', length = nPoints * 2)
points[seq(1, by = 2, length.out = nPoints)] <- format(round(shifts[["stagePoints"]][[i]], 2), nsmall = 2)
points[seq(2, by = 2, length.out = nPoints)] <- format(round(shifts[["shiftPoints"]][[i]], 2), nsmall = 2)
shftChar <- paste(points, collapse = ', ')
df <- rbind(df, data.frame('Curve' = shifts[["shiftId"]][i],
'Rating' = shifts[["rating"]][i],
'Date'= formatUTCTimeLabel(time),
'Points' = shftChar,
'Comments' = shifts[["comments"]][i]))
}
names(df) <- c('Shift Curve #', 'Rating', 'Date & Time', 'Variable Shift Points', 'Comments')
addKableOpts(df, tableId = "vdiagram-table")
}
}
#' Excluded Conditions Message
#' @description Generates the excluded conditions message to show on the plot
#' @param reportObject The full report JSON object
excludedConditionsMessage <- function(reportObject){
excludedConditions <- parseExcludedControlConditions(reportObject)
returnString <- createControlConditionsString(excludedConditions)
if(nchar(returnString) > 0){
returnString <- paste("***Measurements with the following control conditions are excluded: ***", returnString)
}
return(returnString)
}
addKableOpts <- function(df, tableId){
format <- 'html'
alignVal = c('c', 'c', 'l', 'l','l')
table_out <- kable( df, format=format, table.attr = sprintf("id=\"%s\" border=\"1\" class=\"table-cell\"", tableId), align=alignVal)
return(table_out)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.