Merge pull request #593 from thongsav-usgs/master

Separated vdiagram data into two distinct types.

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

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")