MODISTools2/R/QualityCheck.R

QualityCheck <-
function(Data, Product, Band, NoDataFill, QualityBand, QualityScores, QualityThreshold)
{
  ##### Define what valid ranges for quality bands should be for different products:
  # 1=lower range     2=upper range     3=no fill value
  QA_RANGE <- data.frame(
    MOD09A1 = c(0,4294966531,NA),            # Surface reflectance bands 0-1 bits
    MYD09A1 = c(0,4294966531,NA),            # Surface reflectance bands 0-1 bits
    MOD11A2 = c(0,255,NA),                   # Land surface temperature and emissivity 0-1 bits
    MYD11A2 = c(0,255,NA),                   # Land surface temperature and emissivity 0-1 bits
    MCD12Q1 = c(0,254,255),                  # Land cover types 0-1 bits
    MOD13Q1 = c(0,3,-1),                     # Vegetation indices 0-1 bits
    MYD13Q1 = c(0,3,-1),                     # Vegetation indices 0-1 bits
    MOD15A2 = c(0,254,255),                  # LAI - FPAR 0 bit
    MYD15A2 = c(0,254,255),                  # LAI - FPAR 0 bit
    MOD17A2 = c(0,254,255),                  # GPP 0 bit
    MOD17A3 = c(0,100,NA),                   # GPP funny one - evaluate separately
    MCD43A4 = c(0,4294967294,4294967295),    # BRDF albedo band quality, taken from MCD43A2, for reflectance data
    MOD16A2 = c(0,254,255)                   # 8-day, monthly ET/LE/PET/PLE, annual LE/PLE. Same data as MOD15A2 QC
  )
  row.names(QA_RANGE) <- c("min","max","noData")
  # Land cover dynamics products are available for download but not for quality checking with this function.

  # Check the product input corresponds to one with useable quality information
  if(!any(names(QA_RANGE) == Product)) stop("QualityCheck cannot be used for ",Product," product.")

  # If dataframes, coerce to matrices.
  if(is.data.frame(Data)) Data <- as.matrix(Data)
  if(is.data.frame(QualityScores)) QualityScores <- as.matrix(QualityScores)

  # Check that Data and QualityScores have matching length and, if a matrix, dimensions .
  if(is.matrix(Data) | is.matrix(QualityScores)){
    if(!(is.matrix(Data) & is.matrix(QualityScores))) stop("Data and QualityScores do not have matching dimensions.")
    if(!all(dim(Data) == dim(QualityScores))) stop("Data and QualityScores do not have matching dimensions.")
  } else {
    if(length(Data) != length(QualityScores)) stop("Data and QualityScores must have matching lengths.")
  }

  # Check the QualityScores input are within the correct range for the product requested.
  if(is.na(QA_RANGE["noData",Product])){
    if(any(QualityScores < QA_RANGE["min",Product] | QualityScores > QA_RANGE["max",Product]))
      stop("QualityScores not all in range of ",Product,"'s QC: ",QA_RANGE["min",Product],"-",QA_RANGE["max",Product])
  } else {
    qualityScoresInvalid <- ifelse(QualityScores != QA_RANGE["noData",Product],
                                   QualityScores < QA_RANGE["min",Product] | QualityScores > QA_RANGE["max",Product],
                                   FALSE)
    if(any(qualityScoresInvalid))
      stop("QualityScores not all in range of ",Product,"'s QC: ",QA_RANGE["min",Product],"-",QA_RANGE["max",Product])
  }

  # Quality Threshold should be one integer.
  if(length(QualityThreshold) != 1) stop("QualityThreshold input must be one integer.")
  if(!is.numeric(QualityThreshold)) stop("QualityThreshold should be numeric class. One integer.")
  if(abs(QualityThreshold - round(QualityThreshold)) > .Machine$double.eps^0.5){
    stop("QualityThreshold input must be one integer.")
  }

  # NoDataFill should be one integer.
  if(length(NoDataFill) != 1) stop("NoDataFill input must be one integer.")
  if(!is.numeric(NoDataFill)) stop("NoDataFill should be numeric class. One integer.")
  if(abs(NoDataFill - round(NoDataFill)) > .Machine$double.eps^0.5) stop("NoDataFill input must be one integer.")

  # Check QualityThreshold is within 0-3 for all except LAI, ET and GPP bands, which must be within 0-1, and MOD17A3 (0-100).
  lai.gpp.prods <- c("MOD15A2", "MYD15A2", "MOD16A2", "MOD17A2")
  if(any(lai.gpp.prods == Product)){
    if(QualityThreshold != 0 & QualityThreshold != 1){
      stop("QualityThreshold should be either 0 or 1 for this product; 0 is good quality, 1 is other.")
    }
  } else if(Product != "MOD17A3"){
    if(QualityThreshold < 0 | QualityThreshold > 3){
      stop("QualityThreshold should be between 0-3 for this product;
           0 = high quality, 1 = good but marginal quality, 2 = cloudy/poor quality, 3 = poor quality for other reasons.")
    }
  }

  # Check whether all QualityScores are no data fills scores.
  # If so, then return Data with NoDataFill removed, without quality screening.
  if(all(QualityScores == QA_RANGE["noData",Product])){
    warning("Quality checking aborted for this subset because all QualityScores were missing data.",
            call.=FALSE, immediate.=TRUE)
    return(matrix(ifelse(Data != NoDataFill, Data, NA), nrow = nrow(Data)))
  }
  #####

  # MOD17A3 is an exception, so deal with this first, and then the rest,
  if(Product == "MOD17A3"){
    if(QualityThreshold < 0 | QualityThreshold > 100) stop("QualityThreshold should be between 0-100 for this product.")

    NOFILLRANGE <- c(250, 255)
    Data <- ifelse(Data > NOFILLRANGE[1] & Data < NOFILLRANGE[2], Data, NA)
    Data <- ifelse(QualityScores <= QualityThreshold, Data, NA)
  } else {
    # Convert decimal QualityScores values into binary.
    decimal.set <- QualityScores

    if(max(QualityScores) == 0) num.binary.digits <- 1
    if(max(QualityScores) != 0) num.binary.digits <- floor(log(max(QualityScores), base = 2)) + 1

    binary.set<- matrix(nrow = length(QualityScores), ncol = num.binary.digits)

    for(n in 1:num.binary.digits){
      binary.set[ ,(num.binary.digits - n) + 1] <- decimal.set %% 2
      decimal.set <- decimal.set %/% 2
    }

    quality.binary <- apply(binary.set, 1, function(x) paste(x, collapse = ""))

    # Deal with the quality data in binary, according to the product input.
    if(any(lai.gpp.prods == Product)){
      qa.binary <- as.numeric(substr(quality.binary, nchar(quality.binary), nchar(quality.binary)))
      Data <- ifelse(Data != NoDataFill & qa.binary <= QualityThreshold, Data, NA)
    } else {
      # Create an ifelse here so if MCD43A4, snip the relevant binary string for Band. Otherwise, carry on.
      if(Product == "MCD43A4"){
        band.num <- as.numeric(substr(Band, nchar(Band), nchar(Band)))
        if(any(is.na(band.num))) stop("Band input is not one of the reflectance bands (1-7) from MCD43A4.")
        if(any(1 < band.num & band.num > 7)) stop("Band input is not one of the reflectance bands (1-7) from MCD43A4.")

        # Select the section of binary code relevant to Band.
        qa.binary <- substr(quality.binary, (nchar(quality.binary) - (((band.num - 1) * 2) + 2)),
                                            (nchar(quality.binary) - ((band.num - 1) * 2)))

        qa.int <- numeric(length(qa.binary))
        qa.int[qa.binary == "000"] <- 0
        qa.int[qa.binary == "001"] <- 1
        qa.int[qa.binary == "010"] <- 2
        qa.int[qa.binary == "011"] <- 3
        qa.int[qa.binary == "100"] <- 4

        Data <- ifelse(Data != NoDataFill & qa.int <= QualityThreshold, Data, NA)
      } else {
        qa.binary <- substr(quality.binary, nchar(quality.binary) - 1, nchar(quality.binary))

        qa.int <- numeric(length(qa.binary))
        qa.int[qa.binary == "00"] <- 0
        qa.int[qa.binary == "01"] <- 1
        qa.int[qa.binary == "10"] <- 2
        qa.int[qa.binary == "11"] <- 3

        Data <- ifelse(Data != NoDataFill & qa.int <= QualityThreshold, Data, NA)
      }
    }
  }
  return(Data)
}