feature: load bundles from xml character vectors

[polar-fhir]

feature: load bundles from xml character vectors

[palmjulia]

Hi! Thanks or the suggestion and sorry for the late reply, I'm on parental leave until September and will start working actively on the package development again when I'm back. I'm happy to include this function then.

Just to be clear: checkArgString() is you own function, right? I think I get what it's doing but would you mind sharing the funktion definition? Would be quicker to implement once I'm back on it :)

[rennkater]

Hi! Thanks or the suggestion and sorry for the late reply, I'm on parental leave until September and will start working actively on the package development again when I'm back. I'm happy to include this function then.

Just to be clear: checkArgString() is you own function, right? I think I get what it's doing but would you mind sharing the funktion definition? Would be quicker to implement once I'm back on it :)

Hi,
that's great news, congratulations for your offspring :)
Here are some functions from one of my packages, but they are not shared on github yet.
One package has functions for checking arguments in other functions and stop with a meaningful error message. I guess that there are better ways to write that, but it works for me. Here is the content of my arguments.R (I cannot attach R files here):

emailregex <-
  "[a-zA-Z0-9\\-_][a-zA-Z0-9\\.\\-_]*@[a-zA-Z0-9\\-]+(\\.[a-zA-Z0-9\\-_]+)*\\.[a-zA-Z]{2,6}"

#' Check entries of given list or vector against given classes.
#'
#' Throws an exception if invalid value.
#'
#' @param val A list or vector to check.
#' @param classes A character vector of classes, that must be a subset of all classes of objects in list.
#' @export
checkEntriesForClasses <- function(val, classes = NULL) {
  checkArgString("classes",
    classes,
    vector = TRUE,
    pattern = "^[a-zA-Z\\_]+[a-zA-Z0-9\\_]*$"
  )
  ok <- sapply(val, function(v) {
    all(classes %in% class(v))
  })
  if (any(!ok)) {
    stop(
      "entries at these indexes don't have the classes '",
      toString(classes),
      "': ",
      which(!ok)
    )
  }
  return(TRUE)
}


#' Check variable for being vector or single value.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @param classes A character vector of classes, that must be a subset of all classes of objects in list. Optional, default NULL.
#' @param named A logical, TRUE if var must be named. Optional, default FALSE.
#' @export
checkVector <- function(var,
                        val,
                        vector = FALSE,
                        classes = NULL,
                        named = FALSE) {
  if (vector && ((!is.vector(val) && !isDateTime(val) && !lubridate::is.Date(val)) || length(val) == 0)) {
    stop(
      paste0(
        "invalid value for argument '",
        var,
        "': expected vector, but no value was given: '",
        utils::capture.output(str(val, width = 128)),
        "'"
      )
    )
  }
  if (!vector && length(val) != 1) {
    stop(
      "invalid value for argument '",
      var,
      "': expected single value, but vector was given: '",
      utils::capture.output(str(val, width = 128)),
      "'"
    )
  }
  if (named &&
    (is.null(names(val)) ||
      length(names(val)) != length(val))) {
    stop(
      "invalid value for argument '",
      var,
      "': vector has no names or some entries are not named: length=",
      length(val),
      " != ",
      length(names(val)),
      " names: ",
      toString(names(val))
    )
  }
  if (!is.null(classes)) {
    checkEntriesForClasses(val, classes)
  }

  return(TRUE)
}

#' Check variable for being a list.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param classes A character vector of classes, that must be a subset of all classes of objects in list. Optional, default NULL.
#' @param named A logical, TRUE if var must be named. Optional, default FALSE.
#' @export
checkArgList <- function(var,
                         val,
                         classes = NULL,
                         named = FALSE) {
  if (!is.list(val)) {
    stop(
      "invalid value for argument '",
      var,
      "': is not a list but '",
      toString(class(val)),
      "' with content ",
      utils::capture.output(str(val, width = 128))
    )
  }
  if (named &&
    (is.null(names(val)) ||
      length(names(val)) != length(val))) {
    stop(
      "invalid value for argument '",
      var,
      "': list has no names or some entries are not named: length=",
      length(val),
      " != ",
      length(names(val)),
      " names: ",
      toString(names(val))
    )
  }
  if (!is.null(classes)) {
    checkEntriesForClasses(val, classes)
  }
  return(TRUE)
}


#' Check variable for being vector or single value.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgTime <- function(var,
                         val,
                         vector = FALSE) {
  checkVector(var, val, vector = vector)
  if (!isDateTime(val)) {
    stop(
      "invalid value for argument '",
      var,
      "': expected class to one of POSIXct, POSIXt, but got '",
      toString(class(val))
    )
  }
  return(TRUE)
}


#' Check variables value for valid file function.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @export
checkArgFunc <- function(var,
                         val) {
  if (!is.function(val)) {
    stop(
      "invalid value for argument '",
      var,
      "': not a function but '",
      toString(class(val)),
      "'"
    )
  }
  return(TRUE)
}


#' Check variables value for valid file or directory path.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param isfile A logical, TRUE to check for a file, FALSE to check for a directory
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @param existence A logical, TRUE if file path must exist. Optional, default TRUE.
#' @export
checkArgPath <-
  function(var,
           val,
           isfile,
           vector = FALSE,
           existence = TRUE) {
    checkVector(var, val, vector = vector)

    errors <- c()
    for (x in val) {
      if (!(is.character(x) &&
        nchar(trimws(x)) > 0)) {
        errors <- c(
          errors,
          paste0(
            "not a character: '",
            utils::capture.output(str(x, width = 128)),
            "'"
          )
        )
      }
      if (existence) {
        ## file.exists and dir.exists each return TRUE for file and directory
        ## but file.info(x)$isdir is TRUE for directories and FALSE for files
        if (isfile) {
          if (!file.exists(x)) {
            errors <- c(
              errors,
              paste0(
                "file does not exist: '",
                utils::capture.output(str(x, width = 128)),
                "'"
              )
            )
          } else if (file.info(x)$isdir) {
            errors <- c(
              errors,
              paste0(
                "exists but is a directory and not a file: '",
                utils::capture.output(str(x, width = 128)),
                "'"
              )
            )
          }
        } else {
          if (!dir.exists(x)) {
            errors <- c(
              errors,
              paste0(
                "directory does not exist: '",
                utils::capture.output(str(x, width = 128)),
                "'"
              )
            )
          } else if (!file.info(x)$isdir) {
            errors <- c(
              errors,
              paste0(
                "exists but is a file and not a directory: '",
                utils::capture.output(str(x, width = 128)),
                "'"
              )
            )
          }
        }
      }
    }

    if (length(errors) > 0) {
      stop(
        "invalid value for argument '",
        var,
        "': '",
        paste(errors, collapse = "; ")
      )
    }
    return(TRUE)
  }


#' Check variables value for valid email address.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param with.label A logical, TRUE to check for a mail with label. Optional, default TRUE.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgEmail <-
  function(var,
           val,
           with.label = TRUE,
           vector = FALSE) {
    ## simplified regex, skipped characters like !#$%&’*+/=?^_`{|}~
    emailregex <-
      "[a-z0-9\\-_][a-z0-9\\.\\-_]*@[a-z0-9\\-]+(\\.[a-z0-9\\-_]+)*\\.[a-z]{2,6}"
    if (with.label) {
      emailregex <- paste0("^[^<>@]* <", emailregex, ">$")
    } else {
      emailregex <- paste0("^", emailregex, "$")
    }

    checkVector(var, val, vector = vector)

    errors <- c()
    for (x in val) {
      if (!is.character(x) ||
        !grepl(emailregex, x, ignore.case = TRUE)) {
        errors <- c(
          errors,
          paste0(
            "invalid email: '",
            utils::capture.output(str(x, width = 128)),
            "'"
          )
        )
      }
    }
    if (length(errors) > 0) {
      stop(
        "invalid value for argument '",
        var,
        "': '",
        paste(errors, collapse = "; ")
      )
    }
    return(TRUE)
  }


#' Check variables value for valid regular expression.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgRegex <-
  function(var, val, vector = FALSE) {
    checkVector(var, val, vector = vector)

    errors <- c()
    for (x in val) {
      if (!is.character(x) || !isRegex(x)) {
        errors <- c(
          errors,
          paste0(
            "invalid regular expression: '",
            utils::capture.output(str(x, width = 128)),
            "'"
          )
        )
      }
    }

    if (length(errors) > 0) {
      stop(
        "invalid value for argument '",
        var,
        "': '",
        paste(errors, collapse = "; ")
      )
    }

    return(TRUE)
  }


#' Check variables value for valid string.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param pattern A string giving a regular expression to check. Optional, default NULL.
#' @param values A vector of strings giving a list of allowed values. Optional, default NULL.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgString <-
  function(var,
           val,
           pattern = NULL,
           values = NULL,
           vector = FALSE) {
    checkVector(var, val, vector = vector)

    errors <- c()
    for (x in val) {
      if (!(
        is.character(x) &&
          (
            is.null(pattern) ||
              !isRegex(pattern) ||
              grepl(pattern, x, ignore.case = TRUE)
          ) &&
          (
            is.null(values) ||
              !is.character(values) ||
              x %in% values
          )
      )) {
        errors <- c(
          errors,
          paste0(
            "invalid string: '",
            utils::capture.output(str(x, width = 128)),
            "'"
          )
        )
      }
    }

    if (length(errors) > 0) {
      stop(
        "invalid value for argument '",
        var,
        "': '",
        paste(errors, collapse = "; ")
      )
    }

    return(TRUE)
  }


#' Check variables value for Date string.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgDateString <-
  function(var, val, vector = FALSE) {
    result <-
      checkArgString(var,
        val,
        pattern = "^\\d{1,2}\\.\\d{1,2}\\.\\d{2,4}|\\d{4}-\\d{1,2}-\\d{1,2}$",
        vector = vector
      )

    checkVector(var, val, vector = vector)

    errors <- c()
    for (x in val) {
      parsed.date <- NULL
      tryCatch(
        {
          parsed.date <- as.Date.character(x, tryFormats = c("%Y-%m-%d", "%d.%m.%Y"))
        },
        error = function(e) {}
      )
      if (is.null(parsed.date) ||
        is.na(parsed.date)) {
        errors <- c(
          errors,
          paste0(
            "invalid date string: '",
            utils::capture.output(str(x, width = 128)),
            "'"
          )
        )
      }
    }

    if (length(errors) > 0) {
      stop(
        "invalid value for argument '",
        var,
        "': '",
        paste(errors, collapse = "; ")
      )
    }

    return(result)
  }

#' Check variables value for Date.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgDate <-
  function(var, val, vector = FALSE) {
    return(checkVector(var, val, vector = vector, classes = c("Date")))
  }


#' Check variables value for logical
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgLogical <-
  function(var, val, vector = FALSE) {
    checkVector(var, val, vector = vector)

    errors <- c()
    for (x in val) {
      if (!is.logical(x)) {
        errors <- c(
          errors,
          paste0(
            "invalid logical: '",
            utils::capture.output(str(x, width = 128)),
            "'"
          )
        )
      }
    }

    if (length(errors) > 0) {
      stop(
        "invalid value for argument '",
        var,
        "': '",
        paste(errors, collapse = "; ")
      )
    }

    return(TRUE)
  }


#' Check variables value for numeric value.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param pred A function returning TRUE or FALSE on a value. Optional, default NULL.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgNum <-
  function(var,
           val,
           pred = NULL,
           vector = FALSE) {
    checkVector(var, val, vector = vector)
    if (!is.numeric(val) && !is.integer(val)) {
      stop(
        "value of argument '",
        var,
        "' is not numeric: '",
        utils::capture.output(str(val, width = 128)),
        "'"
      )
    }
    errors <- c()
    if (!is.null(pred)) {
      for (x in val) {
        if (!pred(x)) {
          errors <- c(
            errors,
            paste0(
              "invalid numeric: '",
              utils::capture.output(str(x, width = 128)),
              "'"
            )
          )
        }
      }
    }

    if (length(errors) > 0) {
      stop(
        "invalid value for argument '",
        var,
        "': '",
        paste(errors, collapse = "; ")
      )
    }

    return(TRUE)
  }

#' Check variables value for numeric value greater than 0.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgNumGt0 <-
  function(var, val, vector = FALSE) {
    checkArgNum(
      var,
      val,
      pred = function(x) {
        x > 0
      },
      vector = vector
    )
  }

#' Check variables value for numeric value greater than or equal to 0.
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param vector A logical, TRUE if var is a vector. Optional, default FALSE.
#' @export
checkArgNumGte0 <-
  function(var, val, vector = FALSE) {
    checkArgNum(
      var,
      val,
      pred = function(x) {
        x >= 0
      },
      vector = vector
    )
  }

#' Check variables value for data.frame or data.table
#'
#' Throws an exception if invalid value.
#'
#' @param var A string identifying the variable.
#' @param val An arbitrary object, value of the variable.
#' @param columns A vector of strings giving a list of required columns. Optional, default NULL.
#' @export
checkArgDataFrame <-
  function(var, val, columns = NULL) {
    if (length(intersect(
      c("data.table", "data.frame"),
      class(val)
    )) == 0) {
      stop(
        "invalid value for argument '",
        var,
        "': expecting class of 'data.table' or 'data.frame' but got '",
        toString(class(val)),
        "'"
      )
    }
    if (!is.null(columns)) {
      missing.cols <- setdiff(columns, names(val))
      if (length(missing.cols) > 0) {
        stop(
          "invalid value for argument '",
          var,
          "': missing columns '",
          toString(missing.cols),
          "'"
        )
      }
    }
    return(TRUE)
  }

[palmjulia]

Hi @rennkater , I've added a new function in the linked pull request. It's called as_fhir() and I havent kept the indices argument because I think it's easier to just subset on your input vector if you need that.

Please let me know if this function helps or whether you have improvements or comments. Thanks!

[palmjulia]

@rennkater quick reminder: does the function work for you? Then i'd merge it into the master.

[rennkater]

@rennkater quick reminder: does the function work for you? Then i'd merge it into the master.

Hi, yes, looks fine, I'd like that, please merge.
Thank you