diff --git a/R/vdiagram-data.R b/R/vdiagram-data.R index e84bf27b..de06eb3e 100644 --- a/R/vdiagram-data.R +++ b/R/vdiagram-data.R @@ -1,30 +1,9 @@ -#' Parse Vdiagram Data -#' @description Takes in a V diagram report and returns the necessary data for a V Diagram +#' Parse Field Measurement Data +#' @description Takes in a V diagram report and returns the field visit measurement data #' @param reportObject An R object with the raw data required for a V Diagram -#' @return A list containing the relevant data for a V Diagram +#' @return A list containing the field visit measurement data #' -parseVDiagramData <- function(reportObject){ - - ### Which of these are required? None of them stop if they're not valid currently. - ### Alternatively, do we want to assign validParam(blah, blah) to each (i.e. shiftPoints <- validParam(etc,etc)) - ### I assume we do as otherwise the "validParam" statements do nothing. - - shiftPoints <- fetchRatingShiftsField(reportObject, "shiftPoints") - validParam(shiftPoints, "shiftPoints") - - stagePoints <- fetchRatingShiftsField(reportObject, "stagePoints") - validParam(stagePoints, "stagePoints") - - shiftId <- fetchRatingShiftsField(reportObject, "shiftNumber") - validParam(shiftId, "shiftNumber") - - startTime <- fetchRatingShiftsField(reportObject, "applicableStartDateTime") - validParam(startTime, "applicableStartDateTime") - - rating <- fetchRatingShiftsField(reportObject, "curveNumber") - validParam(rating, "curveNumber") - - +parseFieldMeasurementData <- function(reportObject){ maxShift <- fetchMeasurementsField(reportObject, "errorMaxShiftInFeet") validParam(maxShift, "errorMaxShiftInFeet") @@ -41,37 +20,53 @@ parseVDiagramData <- function(reportObject){ validParam(obsGage, "meanGageHeight") ### Is this correct to validate this param? - obsCallOut <- fetchMeasurementsField(reportObject, "measurementNumber") - validParam(obsCallOut, "measurementNumber") + measurementNumber <- fetchMeasurementsField(reportObject, "measurementNumber") + validParam(measurementNumber, "measurementNumber") histFlag <- defaultHistFlags(fetchMeasurementsField(reportObject,"historic")) - maxStage <- fetchMaxStage(reportObject) - validParam(maxStage, "maxStage") + return(list( + maxShift=maxShift, + minShift=minShift, + obsShift=obsShift, + obsIDs=obsIDs, + obsGage=obsGage, + measurementNumber=measurementNumber, + histFlag=histFlag)) +} + +#' Parse Rating Shifts Data +#' @description Takes in a V diagram report and returns the rating shift information +#' @param reportObject An R object with the raw data required for a V Diagram +#' @return A list containing rating shift information +#' +parseRatingShiftsData <- function(reportObject){ + shiftPoints <- fetchRatingShiftsField(reportObject, "shiftPoints") + validParam(shiftPoints, "shiftPoints") + + stagePoints <- fetchRatingShiftsField(reportObject, "stagePoints") + validParam(stagePoints, "stagePoints") - minStage <- fetchMinStage(reportObject) - validParam(minStage, "minStage") + shiftId <- fetchRatingShiftsField(reportObject, "shiftNumber") + validParam(shiftId, "shiftNumber") + + startTime <- fetchRatingShiftsField(reportObject, "applicableStartDateTime") + validParam(startTime, "applicableStartDateTime") + + rating <- fetchRatingShiftsField(reportObject, "curveNumber") + validParam(rating, "curveNumber") ratingShifts <- fetchRatingShifts(reportObject) numOfShifts <- ifelse(!isEmptyOrBlank(ratingShifts), sizeOf(ratingShifts), 0) return(list( - shiftPoints=shiftPoints, - stagePoints=stagePoints, - shiftId=shiftId, - startTime=startTime, - rating=rating, - maxShift=maxShift, - minShift=minShift, - obsShift=obsShift, - obsIDs=obsIDs, - obsGage=obsGage, - obsCallOut=obsCallOut, - histFlag=histFlag, - numOfShifts=numOfShifts, - maxStage=maxStage, - minStage=minStage)) + shiftPoints=shiftPoints, + stagePoints=stagePoints, + shiftId=shiftId, + startTime=startTime, + numOfShifts=numOfShifts, + rating=rating)) } #' History Measurements Label diff --git a/R/vdiagram-render.R b/R/vdiagram-render.R index 71045724..40c8fc03 100644 --- a/R/vdiagram-render.R +++ b/R/vdiagram-render.R @@ -7,14 +7,17 @@ renderVDiagram <- function(reportObject) { styles <- getVDiagramStyle() - vdiagramData <- parseVDiagramData(reportObject) + measurements <- parseFieldMeasurementData(reportObject) + shifts <- parseRatingShiftsData(reportObject) - possibleFields <- c("maxShift", "minShift", "shiftId") - relevantData <- unname(unlist(vdiagramData[possibleFields])) - relevantData <- relevantData[which(!is.na(relevantData))] + maxStage <- fetchMaxStage(reportObject) + validParam(maxStage, "maxStage") + + minStage <- fetchMinStage(reportObject) + validParam(minStage, "minStage") #Check if we have any data to plot. If we don't, return NULL - if(isEmptyOrBlank(relevantData)){ + if(!hasEnoughVdiagramData(measurements, shifts)){ return(NULL) } @@ -25,20 +28,20 @@ renderVDiagram <- function(reportObject) { # max./min. stage lines at top/bottom of plot vplot <- do.call(abline, append( - list(object = vplot, a = vdiagramData$maxStage), styles$maxStageLine + list(object = vplot, a = maxStage), styles$maxStageLine )) vplot <- do.call(abline, append( - list(object = vplot, a = vdiagramData$minStage), styles$minStageLine + list(object = vplot, a = minStage), styles$minStageLine )) - vplot <- addMeasurementsAndError(vplot, vdiagramData, styles) - vplot <- addRatingShifts(vplot, vdiagramData, styles) + 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, vdiagramData$minStage)), - max(c(ylim(vplot)$side.2, vdiagramData$maxStage)) + 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) @@ -56,68 +59,93 @@ renderVDiagram <- function(reportObject) { return(vplot) } -addMeasurementsAndError <- function(vplot, vdiagramData, styles) { - histFlag <- vdiagramData$histFlag +#' Has Enough Vdiagram Data +#' @description returns true if we have enough data to plot +hasEnoughVdiagramData <- function(measurements, shifts) { + relevantMeasurementData <- unname(unlist(measurements[c("maxShift", "minShift")])) + relevantMeasurementData <- relevantMeasurementData[which(!is.na(relevantMeasurementData))] + hasEnough <- !isEmptyOrBlank(relevantMeasurementData) + + relevantShiftData <- unname(unlist(shifts[c("shiftId")])) + relevantShiftData <- relevantShiftData[which(!is.na(relevantShiftData))] + hasEnough <- !isEmptyOrBlank(relevantShiftData) && hasEnough + + 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(vdiagramData$minShift)), which(!is.na(vdiagramData$maxShift))) + arrow_notNA <- intersect(which(!is.na(measurements$minShift)), which(!is.na(measurements$maxShift))) arrow_notNA_hist <- intersect(arrow_notNA, which(histFlag)) - minShift <- vdiagramData$minShift[arrow_notNA_hist] - maxShift <- vdiagramData$maxShift[arrow_notNA_hist] - obsGage <- vdiagramData$obsGage[arrow_notNA_hist] + 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(vdiagramData$obsShift)), which(histFlag)) - x <- vdiagramData$obsShift[point_notNA_hist] - y <- vdiagramData$obsGage[point_notNA_hist] + 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(!vdiagramData$histFlag)){ - arrow_notNA <- intersect(which(!is.na(vdiagramData$minShift)), which(!is.na(vdiagramData$maxShift))) + 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 <- vdiagramData$minShift[arrow_notNA_nothist] - maxShift <- vdiagramData$maxShift[arrow_notNA_nothist] - obsGage <- vdiagramData$obsGage[arrow_notNA_nothist] + 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(vdiagramData$obsShift)), which(!histFlag)) - x <- vdiagramData$obsShift[point_notNA_nothist] - y <- vdiagramData$obsGage[point_notNA_nothist] - obsIDs <- vdiagramData$obsIDs[point_notNA_nothist] - obsCallOut <- vdiagramData$obsCallOut[point_notNA_nothist] - if (!isEmptyOrBlank(x) || !isEmptyOrBlank(y) || !isEmptyOrBlank(obsIDs) || !isEmptyOrBlank(obsCallOut)) { + 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] + if (!isEmptyOrBlank(x) || !isEmptyOrBlank(y) || !isEmptyOrBlank(obsIDs) || !isEmptyOrBlank(measurementNumber)) { vplot <- do.call(points, append(list(object=vplot,x=x, y=y, col = as.numeric(obsIDs)+1), styles$err_points)) - vplot <- do.call(callouts, list(object=vplot, x = x, y = y, labels=obsCallOut)) + vplot <- do.call(callouts, list(object=vplot, x = x, y = y, labels=measurementNumber)) } } 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, vdiagramData, styles) { - for (id in unique(vdiagramData$shiftId)) { +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(vdiagramData$shiftId == id)[1] + i <- which(shifts[['shiftId']] == id)[1] - x <- vdiagramData$shiftPoints[[i]] - y <- vdiagramData$stagePoints[[i]] - ID <- as.numeric(vdiagramData$shiftId[i]) + 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)) @@ -142,11 +170,10 @@ addRatingShifts <- function(vplot, vdiagramData, styles) { #' @importFrom knitr kable #' @export vdiagramTable <- function(reportObject){ + shifts <- parseRatingShiftsData(reportObject) - vDiagramData <- parseVDiagramData(reportObject) - - startTime <- vDiagramData[["startTime"]] - numOfShifts <- vDiagramData[["numOfShifts"]] + startTime <- shifts[["startTime"]] + numOfShifts <- shifts[["numOfShifts"]] df <- data.frame('Rating' = c(), 'Date'= c(), @@ -157,15 +184,15 @@ vdiagramTable <- function(reportObject){ timeF <- substring(startTime[i], 12, 19) tzF <- substring(startTime[i], 24) - nPoints <- length(vDiagramData[["stagePoints"]][[i]]) + nPoints <- length(shifts[["stagePoints"]][[i]]) points <- vector('numeric', length = nPoints * 2) - points[seq(1, by = 2, length.out = nPoints)] <- format(round(vDiagramData[["stagePoints"]][[i]], 2), nsmall = 2) - points[seq(2, by = 2, length.out = nPoints)] <- format(round(vDiagramData[["shiftPoints"]][[i]], 2), nsmall = 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('Rating' = vDiagramData[["rating"]][i], + df <- rbind(df, data.frame('Rating' = shifts[["rating"]][i], 'Date'= paste(dateF, " at ", timeF, " (UTC ", tzF, ")", sep=''), 'Points' = shftChar, - 'Curve' = vDiagramData[["shiftId"]][i])) + 'Curve' = shifts[["shiftId"]][i])) } names(df) <- c('Rating', 'Date & Time', 'Variable Shift Points', 'Shift Curve #') addKableOpts(df, tableId = "vdiagram-table")