| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Truncate active periods in location-based location file to date-time range of interest- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in a location JSON file for a particular named location- |
-
| 9 | -- |
- #' and truncate the active periods to the date-time range of interest.- |
-
| 10 | -- |
- #' NOTE: This function does not include error checking of the input json, since this function is often run- |
-
| 11 | -- |
- #' in a large loop after the input json has already been checked for conformance to the expected schema.- |
-
| 12 | -- |
- #' If error checking of the input json is desired, use a function like NEONprocIS.base::def.loc.meta.- |
-
| 13 | -- | - - | -
| 14 | -- |
- #' @param NameFileIn Filename (including relative or absolute path). Must be json format.- |
-
| 15 | -- |
- #' @param NameFileOut Filename (including relative or absolute path). Must be json format. Defaults to- |
-
| 16 | -- |
- #' NULL, in which case only the filtered json will be returned in list format- |
-
| 17 | -- |
- #' @param TimeBgn POSIX timestamp of the start time (inclusive)- |
-
| 18 | -- |
- #' @param TimeEnd POSIX timestamp of the end time (non-inclusive). Defaults to NULL, in which case the- |
-
| 19 | -- |
- #' location information will be filtered for the exact time of TimeBgn- |
-
| 20 | -- |
- #' @param Prop character vector of the properties in the location file to retain. Defaults to 'all',- |
-
| 21 | -- |
- #' in which all properties of the original file are retained. Include here the names of properties embedded- |
-
| 22 | -- |
- #' at the top level of each location install entry (e.g. "HOR","VER","Data Rate") as well as within the- |
-
| 23 | -- |
- #' "properties" list of each location install entry (e.g. "context","IS Default Processing Start Date",- |
-
| 24 | -- |
- #' "name","site","domain"). Note that 'active_periods' are always retained. Also note that omission of- |
-
| 25 | -- |
- #' some properties may limit the downstream modules that are able to be run (such as regularization if- |
-
| 26 | -- |
- #' 'Data Rate' is not retained)- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @return A list of location information with truncated active dates. If NameFileOut is specified,- |
-
| 29 | -- |
- #' the truncated location information will also be writted to file in the same json format of NameFileIn- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @references- |
-
| 32 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @keywords Currently none- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @examples- |
-
| 37 | -- |
- #' TimeBgn <- base::as.POSIXct('2018-01-01',tz='GMT)
- |
-
| 38 | -- |
- #' TimeEnd <- base::as.POSIXct('2018-01-02',tz='GMT)
- |
-
| 39 | -- |
- #' NameFileIn <- 'locations.json'- |
-
| 40 | -- |
- #' NameFileOut <- 'filtered_locations.json'- |
-
| 41 | -- |
- #' loc <- def.loc.trnc.actv(NameFileIn,NameFileOut,TimeBgn,TimeEnd)- |
-
| 42 | -- | - - | -
| 43 | -- | - - | -
| 44 | -- |
- #' @seealso Currently none- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @export- |
-
| 47 | -- | - - | -
| 48 | -- |
- # changelog and author contributions / copyrights- |
-
| 49 | -- |
- # Cove Sturtevant (2020-08-19)- |
-
| 50 | -- |
- # original creation- |
-
| 51 | -- |
- # Cove Sturtevant (2022-09-22)- |
-
| 52 | -- |
- # accommodate new format of active periods (always a start and end date if there is- |
-
| 53 | -- |
- # an active period, even if they are null)- |
-
| 54 | -- |
- # remove error checking (see Description for rationale)- |
-
| 55 | -- |
- # Cove Sturtevant (2023-11-16)- |
-
| 56 | -- |
- # add option to filter for select properties- |
-
| 57 | -- |
- ##############################################################################################- |
-
| 58 | -- |
- def.loc.trnc.actv <-- |
-
| 59 | -- |
- function(NameFileIn,- |
-
| 60 | -- |
- NameFileOut = NULL,- |
-
| 61 | -- |
- TimeBgn,- |
-
| 62 | -- |
- TimeEnd = NULL,- |
-
| 63 | -- |
- Prop = 'all',- |
-
| 64 | -- |
- log = NULL) {
- |
-
| 65 | -- |
- # Initialize log if not input- |
-
| 66 | -5x | -
- if (is.null(log)) {
- |
-
| 67 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 68 | -- |
- }- |
-
| 69 | -- | - - | -
| 70 | -5x | -
- FmtTime <- '%Y-%m-%dT%H:%M:%SZ' # Time format in the location file- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # If NULL, set TimeEnd to 1 second after TimeBgn- |
-
| 73 | -5x | -
- if (base::is.null(TimeEnd)) {
- |
-
| 74 | -1x | -
- TimeEnd <- TimeBgn + as.difftime(1, units = 'secs')- |
-
| 75 | -- |
- }- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- # Get formatted character representations of the start and end times- |
-
| 78 | -5x | -
- TimeBgnFmt <- base::format(TimeBgn,format=FmtTime)- |
-
| 79 | -5x | -
- TimeEndFmt <- base::format(TimeEnd,format=FmtTime)- |
-
| 80 | -- |
- - |
-
| 81 | -- |
- # Load in the raw json info- |
-
| 82 | -5x | -
- loc <- rjson::fromJSON(file = NameFileIn, simplify = FALSE)- |
-
| 83 | -- |
- - |
-
| 84 | -- |
- # Pull the active dates, and add start/end dates if not present- |
-
| 85 | -5x | -
- timeActv <- base::lapply(loc$features[[1]]$properties$active_periods,- |
-
| 86 | -5x | -
- FUN=function(idxList){
- |
-
| 87 | -7x | -
- if(!base::is.null(idxList$start_date)){
- |
-
| 88 | -6x | -
- timeBgnIdx <- base::as.POSIXct(idxList$start_date,format=FmtTime,tz='GMT')- |
-
| 89 | -- |
- } else {
- |
-
| 90 | -1x | -
- timeBgnIdx <- TimeBgn- |
-
| 91 | -- |
- }- |
-
| 92 | -7x | -
- if(!base::is.null(idxList$end_date)){
- |
-
| 93 | -6x | -
- timeEndIdx <- base::as.POSIXct(idxList$end_date,format=FmtTime,tz='GMT')- |
-
| 94 | -- |
- } else {
- |
-
| 95 | -1x | -
- timeEndIdx <- TimeEnd- |
-
| 96 | -- |
- }- |
-
| 97 | -7x | -
- if(timeBgnIdx < TimeEnd && timeEndIdx > TimeBgn){
- |
-
| 98 | -- |
- # This is a relevant set of active dates.- |
-
| 99 | -- |
- # Truncate the active range to our range of interest- |
-
| 100 | -4x | -
- if(timeBgnIdx <= TimeBgn){
- |
-
| 101 | -1x | -
- timeBgnIdx <- TimeBgnFmt- |
-
| 102 | -- |
- } else {
- |
-
| 103 | -3x | -
- timeBgnIdx <- idxList$start_date- |
-
| 104 | -- |
- }- |
-
| 105 | -4x | -
- if(timeEndIdx >= TimeEnd){
- |
-
| 106 | -1x | -
- timeEndIdx <- TimeEndFmt- |
-
| 107 | -- |
- } else {
- |
-
| 108 | -3x | -
- timeEndIdx <- idxList$end_date- |
-
| 109 | -- |
- }- |
-
| 110 | -- |
- - |
-
| 111 | -4x | -
- return(list(start_date=timeBgnIdx,end_date=timeEndIdx))- |
-
| 112 | -- |
- } else {
- |
-
| 113 | -3x | -
- return(NULL)- |
-
| 114 | -- |
- }- |
-
| 115 | -- |
- }- |
-
| 116 | -- |
- )- |
-
| 117 | -- |
- - |
-
| 118 | -- |
- # Get rid of the active dates we nulled out- |
-
| 119 | -5x | -
- if (base::length(timeActv) > 0){
- |
-
| 120 | -5x | -
- setKeep <- !(base::unlist(base::lapply(timeActv,is.null)))- |
-
| 121 | -5x | -
- loc$features[[1]]$properties$active_periods <- timeActv[setKeep]- |
-
| 122 | -- |
- }- |
-
| 123 | -- |
- - |
-
| 124 | -- |
- # Filter for particular properties- |
-
| 125 | -5x | -
- if(!('all' %in% Prop)){
- |
-
| 126 | -1x | -
- for (idxLoc in base::seq_len(base::length(loc$features))) {
- |
-
| 127 | -- |
- # Traverse top level- |
-
| 128 | -1x | -
- locIdx <- loc$features[[idxLoc]]- |
-
| 129 | -1x | -
- nameProp <- base::names(locIdx)- |
-
| 130 | -1x | -
- setKeep <- nameProp %in% c('properties','geometry',Prop)
- |
-
| 131 | -1x | -
- locIdx <- locIdx[sort(nameProp[setKeep])] # Also sort to ensure a change in ordering of properties in file results in the same output- |
-
| 132 | -- |
- - |
-
| 133 | -- |
- # Descend into "properties"- |
-
| 134 | -1x | -
- locIdxProp <- locIdx$properties- |
-
| 135 | -1x | -
- nameProp <- base::names(locIdxProp)- |
-
| 136 | -1x | -
- setKeep <- nameProp %in% c(Prop)- |
-
| 137 | -1x | -
- locIdxProp <- locIdxProp[sort(nameProp[setKeep])] # Also sort to ensure a change in ordering of properties in file results in the same output- |
-
| 138 | -- |
- - |
-
| 139 | -- |
- # Put filtered set back into master list- |
-
| 140 | -1x | -
- locIdx$properties <- locIdxProp- |
-
| 141 | -1x | -
- loc$features[[idxLoc]] <- locIdx- |
-
| 142 | -- |
- }- |
-
| 143 | -- |
- }- |
-
| 144 | -- |
- - |
-
| 145 | -- |
- # Write to file- |
-
| 146 | -5x | -
- if (!base::is.null(NameFileOut)) {
- |
-
| 147 | -4x | -
- base::write(rjson::toJSON(loc, indent = 4), file = NameFileOut)- |
-
| 148 | -4x | -
- log$debug(base::paste0('Filtered named location file written successfully to ',NameFileOut))
- |
-
| 149 | -- |
- }- |
-
| 150 | -- |
- - |
-
| 151 | -5x | -
- return(loc)- |
-
| 152 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Write Parquet file- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Write Parquet file from data frame. Optionally input a parquet or- |
-
| 9 | -- |
- #' avro schema to convert column names and/or data types. Any variables of class factor will- |
-
| 10 | -- |
- #' be written as class character.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param data Data frame. Data to write to file. This can also be an object of class arrow_dplyr_query,- |
-
| 13 | -- |
- #' but there is currently only support for auto-creating the schema from the object.- |
-
| 14 | -- |
- #' @param NameFile String. Name (including relative or absolute path) of output parquet file.- |
-
| 15 | -- |
- #' @param Schm Optional. Either a Parquet schema of class ArrowObject, or a Json formatted string- |
-
| 16 | -- |
- #' with an AVRO file schema. Example:\cr- |
-
| 17 | -- |
- #' "{\"type\" : \"record\",\"name\" : \"ST\",\"namespace\" : \"org.neonscience.schema.device\",\"fields\" : [ {\"name\" :\"readout_time\",\"type\" : {\"type\" : \"long\",\"logicalType\" : \"timestamp-millis\"},\"doc\" : \"Timestamp of readout expressed in milliseconds since epoch\"}, {\"name\" : \"soilPRTResistance\",\"type\" : [ \"null\", \"float\" ],\"doc\" : \"DPID: DP0.00041.001 TermID: 1728 Units: ohm Description: Soil Temperature, Level 0\",\"default\" : null} ],\"__fastavro_parsed\" : true}"\cr
- |
-
| 18 | -- |
- #' Defaults to NULL, in which case the schema will be constructed using the argument NameFileSchm- |
-
| 19 | -- |
- #' (if not NULL) or auto-generated from the data frame.- |
-
| 20 | -- |
- #' @param NameFileSchm String. Optional. A filename (include relative or aboslute path) of an avro- |
-
| 21 | -- |
- #' schema file (.avsc format). Defaults to NULL, in which case the schema will be constructed using- |
-
| 22 | -- |
- #' the Schm argument (if not NULL) or auto-generated from the input data.- |
-
| 23 | -- |
- #' @param CompType String. Compression algorithm. Defaults to 'gzip'. Can also be NULL, in which case- |
-
| 24 | -- |
- #' the arrow::write_parquet default will be used.- |
-
| 25 | -- |
- #' @param CompLvl Numeric. Compression level. See documentation for arrow::write_parquet for details.- |
-
| 26 | -- |
- #' @param Dict Logical. Vector either length 1 or the same length as the number of columns in \code{data}
- |
-
| 27 | -- |
- #' representing whether to apply dictionary encoding to each respective data column. If length 1, the- |
-
| 28 | -- |
- #' choice is applied to all data columns. Defaults to NULL, in which case dictionary encoding is- |
-
| 29 | -- |
- #' determined automatically based on the prevalence of repeated values.- |
-
| 30 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 31 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @return The data frame as written to the output.- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @references- |
-
| 36 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @keywords Currently none- |
-
| 39 | -- | - - | -
| 40 | -- |
- #' @examples- |
-
| 41 | -- |
- #' data <- data.frame(x=c(1,2,3),y=c('one','two','three'),stringsAsFactors=FALSE)
- |
-
| 42 | -- |
- #' dataOut <- NEONprocIS.base::def.wrte.parq(data,NameFile='out.parquet')- |
-
| 43 | -- | - - | -
| 44 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.parq}
- |
-
| 45 | -- |
- #' @seealso \link[arrow]{write_parquet}
- |
-
| 46 | -- | - - | -
| 47 | -- |
- #' @export- |
-
| 48 | -- | - - | -
| 49 | -- |
- # changelog and author contributions / copyrights- |
-
| 50 | -- |
- # Cove Sturtevant (2019-04-06)- |
-
| 51 | -- |
- # original creation- |
-
| 52 | -- |
- # Cove Sturtevant (2023-02-21)- |
-
| 53 | -- |
- # Convert avro schema to parquet schema and convert to arrow table before writing parquet file.- |
-
| 54 | -- |
- # This retains the data types (and likely space savings) upon write- |
-
| 55 | -- |
- # Cove Sturtevant (2023-03-08)- |
-
| 56 | -- |
- # Add support for writing object of class arrow_dplyr_query- |
-
| 57 | -- |
- # Support currently limited to auto-detecting schema- |
-
| 58 | -- |
- # Cove Sturtevant (2023-06-06)- |
-
| 59 | -- |
- # Refactor determination of dictionary encoding for performance- |
-
| 60 | -- |
- # Cove Sturtevant (2023-08-15)- |
-
| 61 | -- |
- # if no schema is input, create a parquet schema before writing (which allows e.g. defaulting to float vs. double)- |
-
| 62 | -- |
- # change default compression to zstd (similar compression ratio as gzip but much faster)- |
-
| 63 | -- |
- ##############################################################################################- |
-
| 64 | -- |
- def.wrte.parq <- function(data,- |
-
| 65 | -- |
- NameFile,- |
-
| 66 | -- |
- Schm=NULL,- |
-
| 67 | -- |
- NameFileSchm=NULL,- |
-
| 68 | -- |
- CompType='zstd',- |
-
| 69 | -- |
- CompLvl=5,- |
-
| 70 | -- |
- Dict=NULL,- |
-
| 71 | -- |
- log=NULL- |
-
| 72 | -- |
- ){
- |
-
| 73 | -- |
- - |
-
| 74 | -- |
- # initialize logging if necessary- |
-
| 75 | -12x | -
- if (base::is.null(log)) {
- |
-
| 76 | -12x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -12x | -
- numVar <- base::ncol(data)- |
-
| 80 | -12x | -
- numRow <- base::nrow(data)- |
-
| 81 | -- |
- - |
-
| 82 | -12x | -
- if(base::length(Dict) == 1){
- |
-
| 83 | -3x | -
- Dict <- base::rep(Dict,numVar)- |
-
| 84 | -- |
- }- |
-
| 85 | -- |
- - |
-
| 86 | -- |
- # Error check- |
-
| 87 | -12x | -
- if(!base::is.null(Dict) && (base::length(Dict) != numVar || !is.logical(Dict))){
- |
-
| 88 | -1x | -
- log$error(base::paste0('Input argument Dict must be NULL or a logical vector the same length as the number of columns in data.'))
- |
-
| 89 | -1x | -
- stop()- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- # No schema was explicitly input.- |
-
| 93 | -11x | -
- if(base::is.null(Schm) && base::is.null(NameFileSchm)){
- |
-
| 94 | -- |
- # Look for a schema attached as an attribute of the data (as produced by NEONprocIS.base::def.read.parq)- |
-
| 95 | -7x | -
- schmData = base::attr(data,'schema')- |
-
| 96 | -- |
- - |
-
| 97 | -7x | -
- if(!base::is.null(schmData) && 'ArrowObject' %in% base::class(schmData)){
- |
-
| 98 | -5x | -
- log$debug(base::paste0('Using parquet schema attached as an attribute to the data frame for output file ',NameFile))
- |
-
| 99 | -- |
- } else {
- |
-
| 100 | -2x | -
- schmData <- NULL- |
-
| 101 | -2x | -
- log$debug(base::paste0('Auto-creating schema for output file ',NameFile))
- |
-
| 102 | -- |
- }- |
-
| 103 | -- |
- - |
-
| 104 | -- |
- # Convert data frame to arrow table- |
-
| 105 | -- |
- # Use schema attached as attribute to the data, or auto-construct it from the data frame.- |
-
| 106 | -7x | -
- if("data.frame" %in% base::class(data)){
- |
-
| 107 | -- |
- - |
-
| 108 | -7x | -
- if(!base::is.null(schmData)){
- |
-
| 109 | -- |
- # Pull the col names and data types from the schema- |
-
| 110 | -5x | -
- typeVar <- NEONprocIS.base::def.schm.parq.pars(schmData,log=log)- |
-
| 111 | -- |
- - |
-
| 112 | -- |
- # Rename the variables to match the schema- |
-
| 113 | -5x | -
- if(numVar != base::length(typeVar$name)){
- |
-
| 114 | -2x | -
- log$error(base::paste0('Number of variables in the data do not match number of variables in the schema (schema is attached as an attribute to the data frame).'))
- |
-
| 115 | -2x | -
- stop()- |
-
| 116 | -- |
- } else {
- |
-
| 117 | -3x | -
- base::names(data) <- typeVar$name- |
-
| 118 | -- |
- }- |
-
| 119 | -- |
- - |
-
| 120 | -- |
- } else {
- |
-
| 121 | -- |
- # Auto-detect schema from data frame- |
-
| 122 | -2x | -
- schmData <- NEONprocIS.base::def.schm.parq.from.df(data)- |
-
| 123 | -2x | -
- typeVar <- NEONprocIS.base::def.schm.parq.pars(schmData,log=log)- |
-
| 124 | -- |
- }- |
-
| 125 | -- |
- - |
-
| 126 | -- |
- # In order to reliably apply the schema, we need to do some type conversion of the data first.- |
-
| 127 | -5x | -
- data <- NEONprocIS.base::def.data.conv.type.parq(data=data,type=typeVar,log=log)- |
-
| 128 | -- |
- - |
-
| 129 | -- |
- # Covert to arrow table- |
-
| 130 | -5x | -
- data <- arrow::arrow_table(data, schema=schmData)- |
-
| 131 | -- |
- - |
-
| 132 | -! | -
- } else if ("arrow_dplyr_query" %in% base::class(data)){
- |
-
| 133 | -! | -
- data <- arrow::as_arrow_table(data, schema=schmData)- |
-
| 134 | -- |
- - |
-
| 135 | -- |
- }- |
-
| 136 | -- | - - | -
| 137 | -- |
- # Convert data according to input schema- |
-
| 138 | -- |
- } else {
- |
-
| 139 | -- |
- - |
-
| 140 | -4x | -
- if (!base::is.null(Schm) && 'ArrowObject' %in% base::class(Schm)){
- |
-
| 141 | -- |
- # Schema specified in inputs as a parquet schema.- |
-
| 142 | -2x | -
- log$debug(base::paste0('Using parquet schema from input argument Schm for output file ',NameFile))
- |
-
| 143 | -- |
- - |
-
| 144 | -- |
- # Pull the col names and data types from the schema- |
-
| 145 | -2x | -
- typeVar <- NEONprocIS.base::def.schm.parq.pars(Schm,log=log)- |
-
| 146 | -- |
- - |
-
| 147 | -2x | -
- } else if (!base::is.null(Schm) || !base::is.null(NameFileSchm)) {
- |
-
| 148 | -- |
- - |
-
| 149 | -2x | -
- log$debug(base::paste0('Creating parquet schema from input avro schema for output file ',NameFile))
- |
-
| 150 | -- |
- - |
-
| 151 | -- |
- # Create parquet schema from the avro schema- |
-
| 152 | -2x | -
- Schm <- NEONprocIS.base::def.schm.parq.from.schm.avro(FileSchm=NameFileSchm,Schm=Schm,log=log)- |
-
| 153 | -- |
- - |
-
| 154 | -- |
- # Pull the col names and data types from the schema- |
-
| 155 | -1x | -
- typeVar <- NEONprocIS.base::def.schm.parq.pars(Schm,log=log)- |
-
| 156 | -- |
- - |
-
| 157 | -- |
- }- |
-
| 158 | -- |
- - |
-
| 159 | -- |
- # Rename the variables to match the schema- |
-
| 160 | -3x | -
- if(numVar != base::length(typeVar$name)){
- |
-
| 161 | -1x | -
- log$error(base::paste0('Number of variables in the data do not match number of variables in the schema for output file ',NameFile))
- |
-
| 162 | -1x | -
- stop()- |
-
| 163 | -- |
- } else {
- |
-
| 164 | -2x | -
- base::names(data) <- typeVar$name- |
-
| 165 | -- |
- }- |
-
| 166 | -- |
- # In order to reliably apply the schema, we need to do some type conversion of the data first.- |
-
| 167 | -2x | -
- data <- NEONprocIS.base::def.data.conv.type.parq(data=data,type=typeVar,log=log)- |
-
| 168 | -- |
- - |
-
| 169 | -- |
- # Apply the arrow schema- |
-
| 170 | -2x | -
- data <- arrow::arrow_table(data, schema=Schm)- |
-
| 171 | -- |
- - |
-
| 172 | -- |
- }- |
-
| 173 | -- |
- - |
-
| 174 | -- |
- # Determine whether to use dictionary encoding for each variable- |
-
| 175 | -7x | -
- if (base::is.null(Dict)){
- |
-
| 176 | -- | - - | -
| 177 | -5x | -
- varData <- base::names(data)- |
-
| 178 | -5x | -
- numUniq <- base::lapply(varData,FUN=function(varIdx){
- |
-
| 179 | -- |
- # Doesn't work for some data types. Skip dictionary encoding if error- |
-
| 180 | -18x | -
- numUniqIdx <- try({base::length(base::unique(data$GetColumnByName(varIdx)))},silent=TRUE)
- |
-
| 181 | -18x | -
- if("try-error" %in% class(numUniqIdx)){
- |
-
| 182 | -! | -
- return(numRow)- |
-
| 183 | -- |
- } else {
- |
-
| 184 | -18x | -
- return(numUniqIdx)- |
-
| 185 | -- |
- }- |
-
| 186 | -- |
- })- |
-
| 187 | -5x | -
- base::names(numUniq) <- varData- |
-
| 188 | -5x | -
- Dict <- numUniq < 0.7*numRow- |
-
| 189 | -5x | -
- Dict[is.na(Dict)]<- FALSE- |
-
| 190 | -- | - - | -
| 191 | -- |
- # This is slow, especially for a large number of columns. Replacement above after converting to arrow table.- |
-
| 192 | -- |
- # Works for both arrow tables and class arrow_dplyr_query- |
-
| 193 | -- |
- # NOTE: If upgrade to arrow 11, should be able do use n_distinct() without first collecting to save memory- |
-
| 194 | -- |
- # library(dplyr)- |
-
| 195 | -- |
- # varData <- base::names(data)- |
-
| 196 | -- |
- # numUniq <- base::rep(FALSE,times=base::length(varData))- |
-
| 197 | -- |
- # base::names(numUniq) <- varData- |
-
| 198 | -- |
- # for (varIdx in varData){
- |
-
| 199 | -- |
- # numUniq[varIdx] <- data %>%- |
-
| 200 | -- |
- # dplyr::select(dplyr::all_of(varIdx)) %>%- |
-
| 201 | -- |
- # dplyr::collect() %>%- |
-
| 202 | -- |
- # dplyr::n_distinct()- |
-
| 203 | -- |
- # }- |
-
| 204 | -- |
- # Dict <- numUniq < 0.7*numRow- |
-
| 205 | -- |
- }- |
-
| 206 | -7x | -
- log$debug(base::paste0('Dictionary settings per variable: ',base::paste0(Dict,collapse=' '), ' for output file ',NameFile))
- |
-
| 207 | -- |
- - |
-
| 208 | -- |
- # Write the data- |
-
| 209 | -7x | -
- rpt <- base::try(- |
-
| 210 | -7x | -
- arrow::write_parquet(x=data,- |
-
| 211 | -7x | -
- sink=NameFile,- |
-
| 212 | -7x | -
- compression=CompType,- |
-
| 213 | -7x | -
- compression_level=CompLvl,- |
-
| 214 | -7x | -
- use_dictionary=Dict,- |
-
| 215 | -7x | -
- coerce_timestamps='ms',- |
-
| 216 | -7x | -
- allow_truncated_timestamps=TRUE- |
-
| 217 | -- |
- ),- |
-
| 218 | -7x | -
- silent=FALSE- |
-
| 219 | -- |
- )- |
-
| 220 | -- |
- - |
-
| 221 | -7x | -
- if('try-error' %in% base::class(rpt)){
- |
-
| 222 | -! | -
- log$error(base::paste0('Could not write parquet file ',NameFile))
- |
-
| 223 | -! | -
- stop()- |
-
| 224 | -- |
- } else {
- |
-
| 225 | -7x | -
- log$debug(base::paste0('Wrote parquet file: ',NameFile))
- |
-
| 226 | -7x | -
- return(rpt)- |
-
| 227 | -- |
- }- |
-
| 228 | -- |
- }- |
-
| 1 | -- |
- ###################################################################################################- |
-
| 2 | -- |
- #' @title validate if the JSON content is valid against the json schema- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Mija Choi \email{choim@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Validate an input json against the schema to check it is valid.- |
-
| 9 | -- |
- #' Run validate.json before validate.json.schema- |
-
| 10 | -- |
- #' Returns TRUE if the json is vaild . FALSE if invalid or error.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param jsonIn Input json to be validated- |
-
| 13 | -- | - - | -
| 14 | -- |
- #' @param jsonSchemaIn Input json schema to be validated against- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @return Boolean. TRUE if the input json is valid against the schema. FALSE if not valid. \cr- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @references Currently none- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @keywords Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @examples NEONprocIS.base::def.validate.json.schema (jsonIn, jsonSchemaIn)- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 25 | -- |
- #'- |
-
| 26 | -- |
- #' @export- |
-
| 27 | -- | - - | -
| 28 | -- |
- # changelog and author contributions / copyrights- |
-
| 29 | -- |
- # Mija Choi (2020-01-27)- |
-
| 30 | -- |
- # original creation- |
-
| 31 | -- |
- ##############################################################################################- |
-
| 32 | -- |
- #library(jsonvalidate)- |
-
| 33 | -- | - - | -
| 34 | -- |
- def.validate.json.schema <-- |
-
| 35 | -- |
- function(jsonIn, jsonSchemaIn, log = NULL) {
- |
-
| 36 | -- |
- # Initialize log if not input- |
-
| 37 | -41x | -
- if (base::is.null(log)) {
- |
-
| 38 | -17x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 39 | -- |
- }- |
-
| 40 | -- |
- #set the default to FALSE- |
-
| 41 | -41x | -
- d = FALSE- |
-
| 42 | -- |
- - |
-
| 43 | -41x | -
- tryCatch(- |
-
| 44 | -41x | -
- (base::suppressWarnings(jsonvalidate::json_validate(jsonIn, jsonSchemaIn))),- |
-
| 45 | -41x | -
- error = function(cond) {
- |
-
| 46 | -! | -
- log$error(base::paste0(jsonin, ' error in the JSON schema validation '))- |
-
| 47 | -! | -
- stop()- |
-
| 48 | -- |
- }- |
-
| 49 | -- |
- )- |
-
| 50 | -- |
- #- |
-
| 51 | -- |
- # TRUE if jsonIn is a valid JSON against the schema. FALSE if invalid or error- |
-
| 52 | -- |
- #- |
-
| 53 | -41x | -
- log$debug(- |
-
| 54 | -41x | -
- base::paste0(- |
-
| 55 | -41x | -
- 'Validate.json.schema: Checking to see if the JSON conforms to the schema.'- |
-
| 56 | -- |
- )- |
-
| 57 | -- |
- )- |
-
| 58 | -41x | -
- if (base::suppressWarnings(jsonvalidate::json_validate(jsonIn, jsonSchemaIn))) {
- |
-
| 59 | -32x | -
- d = TRUE- |
-
| 60 | -32x | -
- log$debug(base::paste0(jsonIn, ' conforms to the schema '))- |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- else- |
-
| 63 | -- |
- {
- |
-
| 64 | -9x | -
- log$debug(base::paste0(jsonIn, ' does not conform to the schema '))- |
-
| 65 | -- |
- }- |
-
| 66 | -41x | -
- return (d)- |
-
| 67 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Truncate active periods in group file to date-time range of interest- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in a group JSON file and truncate the active periods to the date-time range of interest.- |
-
| 9 | -- |
- #' NOTE: This function does not include error checking of the input json, since this function is often run- |
-
| 10 | -- |
- #' in a large loop after the input json has already been checked for conformance to the expected schema.- |
-
| 11 | -- |
- #' If error checking of the input json is desired, use a function like NEONprocIS.base::def.loc.meta prior- |
-
| 12 | -- |
- #' to executing this function.- |
-
| 13 | -- | - - | -
| 14 | -- |
- #' @param NameFileIn Filename (including relative or absolute path). Must be json format.- |
-
| 15 | -- |
- #' @param NameFileOut Filename (including relative or absolute path). Must be json format. Defaults to- |
-
| 16 | -- |
- #' NULL, in which case only the filtered json will be returned in list format- |
-
| 17 | -- |
- #' @param TimeBgn POSIX timestamp of the start time (inclusive)- |
-
| 18 | -- |
- #' @param TimeEnd POSIX timestamp of the end time (non-inclusive). Defaults to NULL, in which case the- |
-
| 19 | -- |
- #' group information will be filtered for the exact time of TimeBgn- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @return The file in list format with truncated active dates. If NameFileOut is specified,- |
-
| 22 | -- |
- #' the truncated information will also be writted to file in the same json format of NameFileIn.- |
-
| 23 | -- |
- #' If an active period is empty or becomes empty during truncation (completely outside the range of interest), the- |
-
| 24 | -- |
- #' entire group is removed. If no active groups remain, no file is written.- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @references- |
-
| 27 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @keywords Currently none- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @examples- |
-
| 32 | -- |
- #' TimeBgn <- base::as.POSIXct('2018-01-01',tz='GMT)
- |
-
| 33 | -- |
- #' TimeEnd <- base::as.POSIXct('2018-01-02',tz='GMT)
- |
-
| 34 | -- |
- #' NameFileIn <- 'groups.json'- |
-
| 35 | -- |
- #' NameFileOut <- 'filtered_groups.json'- |
-
| 36 | -- |
- #' listFile <- def.grp.trnc.actv(NameFileIn,NameFileOut,TimeBgn,TimeEnd)- |
-
| 37 | -- | - - | -
| 38 | -- | - - | -
| 39 | -- |
- #' @seealso Currently none- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @export- |
-
| 42 | -- | - - | -
| 43 | -- |
- # changelog and author contributions / copyrights- |
-
| 44 | -- |
- # Cove Sturtevant (2022-11-23)- |
-
| 45 | -- |
- # original creation, from def.loc.trnc.actv- |
-
| 46 | -- |
- # Cove Sturtevant (20234-07-10)- |
-
| 47 | -- |
- # apply sorting to output- |
-
| 48 | -- |
- ##############################################################################################- |
-
| 49 | -- |
- def.grp.trnc.actv <- function(- |
-
| 50 | -- |
- NameFileIn,- |
-
| 51 | -- |
- NameFileOut = NULL,- |
-
| 52 | -- |
- TimeBgn,- |
-
| 53 | -- |
- TimeEnd = NULL,- |
-
| 54 | -- |
- log = NULL- |
-
| 55 | -- |
- ) {
- |
-
| 56 | -- |
- - |
-
| 57 | -- |
- # Initialize log if not input- |
-
| 58 | -7x | -
- if (is.null(log)) {
- |
-
| 59 | -7x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 60 | -- |
- }- |
-
| 61 | -- | - - | -
| 62 | -7x | -
- FmtTime <- '%Y-%m-%dT%H:%M:%SZ' # Time format in the file- |
-
| 63 | -- |
- - |
-
| 64 | -- |
- # If NULL, set TimeEnd to 1 second after TimeBgn- |
-
| 65 | -7x | -
- if (base::is.null(TimeEnd)) {
- |
-
| 66 | -1x | -
- TimeEnd <- TimeBgn + as.difftime(1, units = 'secs')- |
-
| 67 | -- |
- }- |
-
| 68 | -- |
- - |
-
| 69 | -- |
- # Get formatted character representations of the start and end times- |
-
| 70 | -7x | -
- TimeBgnFmt <- base::format(TimeBgn,format=FmtTime)- |
-
| 71 | -7x | -
- TimeEndFmt <- base::format(TimeEnd,format=FmtTime)- |
-
| 72 | -- |
- - |
-
| 73 | -- |
- # Load in the raw json info- |
-
| 74 | -7x | -
- listFile <- rjson::fromJSON(file = NameFileIn, simplify = FALSE)- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Sort the list of groups by group name- |
-
| 77 | -7x | -
- nameGrp <- unlist(lapply(listFile$features,FUN=function(idx){idx$properties$group}))
- |
-
| 78 | -7x | -
- if(base::length(nameGrp) > 1){
- |
-
| 79 | -7x | -
- listFile$features <- listFile$features[order(nameGrp)]- |
-
| 80 | -- |
- }- |
-
| 81 | -- |
- - |
-
| 82 | -- |
- # Run through each group that is present in the file- |
-
| 83 | -7x | -
- for (idx in base::seq_len(base::length(listFile$features))){
- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # Sort for consistent output- |
-
| 86 | -26x | -
- grpIdx <- listFile$features[[idx]]- |
-
| 87 | -26x | -
- nameItem <- base::names(grpIdx)- |
-
| 88 | -26x | -
- listFile$features[[idx]] <- grpIdx[sort(nameItem)]- |
-
| 89 | -- |
- # Descend into "properties"- |
-
| 90 | -26x | -
- if('properties' %in% names(listFile$features[[idx]])){
- |
-
| 91 | -26x | -
- grpIdxProp <- listFile$features[[idx]]$properties- |
-
| 92 | -26x | -
- nameProp <- base::names(grpIdxProp)- |
-
| 93 | -26x | -
- listFile$features[[idx]]$properties <- grpIdxProp[sort(nameProp)]- |
-
| 94 | -- |
- # Sort products- |
-
| 95 | -26x | -
- if('data_product_ID' %in% names(listFile$features[[idx]]$properties)){
- |
-
| 96 | -2x | -
- idDp <- listFile$features[[idx]]$properties$data_product_ID- |
-
| 97 | -2x | -
- listFile$features[[idx]]$properties$data_product_ID <- as.list(sort(unlist(idDp)))- |
-
| 98 | -- |
- }- |
-
| 99 | -- |
- }- |
-
| 100 | -- |
- - |
-
| 101 | -- |
- - |
-
| 102 | -- |
- # Pull the active dates, and add start/end dates if not present- |
-
| 103 | -26x | -
- timeActv <- base::lapply(listFile$features[[idx]]$properties$active_periods,- |
-
| 104 | -26x | -
- FUN=function(idxList){
- |
-
| 105 | -45x | -
- if(!base::is.null(idxList$start_date)){
- |
-
| 106 | -33x | -
- timeBgnIdx <- base::as.POSIXct(idxList$start_date,format=FmtTime,tz='GMT')- |
-
| 107 | -- |
- } else {
- |
-
| 108 | -12x | -
- timeBgnIdx <- TimeBgn- |
-
| 109 | -- |
- }- |
-
| 110 | -45x | -
- if(!base::is.null(idxList$end_date)){
- |
-
| 111 | -35x | -
- timeEndIdx <- base::as.POSIXct(idxList$end_date,format=FmtTime,tz='GMT')- |
-
| 112 | -- |
- } else {
- |
-
| 113 | -10x | -
- timeEndIdx <- TimeEnd- |
-
| 114 | -- |
- }- |
-
| 115 | -45x | -
- if(timeBgnIdx < TimeEnd && timeEndIdx > TimeBgn){
- |
-
| 116 | -- |
- # This is a relevant set of active dates.- |
-
| 117 | -- |
- # Truncate the active range to our range of interest- |
-
| 118 | -23x | -
- if(timeBgnIdx <= TimeBgn){
- |
-
| 119 | -11x | -
- timeBgnIdx <- TimeBgnFmt- |
-
| 120 | -- |
- } else {
- |
-
| 121 | -12x | -
- timeBgnIdx <- idxList$start_date- |
-
| 122 | -- |
- }- |
-
| 123 | -23x | -
- if(timeEndIdx >= TimeEnd){
- |
-
| 124 | -11x | -
- timeEndIdx <- TimeEndFmt- |
-
| 125 | -- |
- } else {
- |
-
| 126 | -12x | -
- timeEndIdx <- idxList$end_date- |
-
| 127 | -- |
- }- |
-
| 128 | -- |
- - |
-
| 129 | -23x | -
- return(list(start_date=timeBgnIdx,end_date=timeEndIdx))- |
-
| 130 | -- |
- } else {
- |
-
| 131 | -22x | -
- return(NULL)- |
-
| 132 | -- |
- }- |
-
| 133 | -- |
- }- |
-
| 134 | -- |
- )- |
-
| 135 | -- |
- - |
-
| 136 | -- |
- - |
-
| 137 | -- |
- - |
-
| 138 | -- |
- # Get rid of the active dates we nulled out- |
-
| 139 | -26x | -
- if (base::length(timeActv) > 0){
- |
-
| 140 | -26x | -
- setKeep <- !(base::unlist(base::lapply(timeActv,is.null)))- |
-
| 141 | -26x | -
- listFile$features[[idx]]$properties$active_periods <- timeActv[setKeep]- |
-
| 142 | -- |
- }- |
-
| 143 | -- |
- - |
-
| 144 | -- |
- # Sort the remaining active periods- |
-
| 145 | -26x | -
- timeActvKeep <- listFile$features[[idx]]$properties$active_periods- |
-
| 146 | -26x | -
- if (base::length(timeActvKeep) > 0){
- |
-
| 147 | -17x | -
- timeBgnActv <- base::unlist(base::lapply(timeActvKeep,FUN=function(idxList){idxList$start_date}))
- |
-
| 148 | -17x | -
- listFile$features[[idx]]$properties$active_periods <- timeActvKeep[base::order(timeBgnActv)]- |
-
| 149 | -- |
- }- |
-
| 150 | -- |
- - |
-
| 151 | -- |
- - |
-
| 152 | -- |
- } # End loop around feature list (number of groups)- |
-
| 153 | -- |
- - |
-
| 154 | -- |
- # Get rid of the groups with no active periods left- |
-
| 155 | -7x | -
- numActv <- base::unlist(- |
-
| 156 | -7x | -
- base::lapply(listFile$features,FUN=function(idxGrp){
- |
-
| 157 | -26x | -
- length(idxGrp$properties$active_periods)- |
-
| 158 | -- |
- })- |
-
| 159 | -- |
- )- |
-
| 160 | -7x | -
- listFile$features[numActv == 0] <- NULL- |
-
| 161 | -7x | -
- if(base::length(listFile$features) == 0){
- |
-
| 162 | -1x | -
- listFile <- NULL- |
-
| 163 | -1x | -
- log$debug(base::paste0('No applicable active periods for time period ',TimeBgn,' to ',TimeEnd, ' in ',NameFileIn))
- |
-
| 164 | -- |
- }- |
-
| 165 | -- |
- - |
-
| 166 | -- |
- # Write to file- |
-
| 167 | -7x | -
- if (!base::is.null(NameFileOut) && !base::is.null(listFile)) {
- |
-
| 168 | -2x | -
- base::write(rjson::toJSON(listFile, indent = 4), file = NameFileOut)- |
-
| 169 | -2x | -
- log$debug(base::paste0('Filtered group file written successfully to ',NameFileOut))
- |
-
| 170 | -- |
- }- |
-
| 171 | -- |
- - |
-
| 172 | -7x | -
- return(listFile)- |
-
| 173 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read Parquet file- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in parquet file.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param NameFile String. Name (including relative or absolute path) of AVRO file.- |
-
| 11 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 12 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 13 | -- |
- #'- |
-
| 14 | -- |
- #' @return A data frame of the data contained in the Parquet file. The schema is included in- |
-
| 15 | -- |
- #' attribute 'schema'. Any other schema metadata included in the parquet file is attached to- |
-
| 16 | -- |
- #' the output data frame in the 'metadata' attribute.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @references- |
-
| 19 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @keywords Currently none- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @examples- |
-
| 24 | -- |
- #' myData <- NEONprocIS.base::def.read.parq(NameFile='/scratch/test/myFile.avro')- |
-
| 25 | -- |
- #' attr(myData,'schema') # Returns the schema- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @seealso Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @export- |
-
| 30 | -- | - - | -
| 31 | -- |
- # changelog and author contributions / copyrights- |
-
| 32 | -- |
- # Cove Sturtevant (2019-04-01)- |
-
| 33 | -- |
- # original creation- |
-
| 34 | -- |
- # Cove Sturtevant (2022-02-10)- |
-
| 35 | -- |
- # Use base::data.frame instead of base::as.data.frame to avoid tibble data frame- |
-
| 36 | -- |
- # Cove Sturtevant (2024-02-25)- |
-
| 37 | -- |
- # Attach metadata included in the parquet file as an attribute of the output dataframe- |
-
| 38 | -- |
- ##############################################################################################- |
-
| 39 | -- |
- def.read.parq <- function(NameFile,- |
-
| 40 | -- |
- log=NULL- |
-
| 41 | -- |
- ){
- |
-
| 42 | -- |
- # initialize logging if necessary- |
-
| 43 | -27x | -
- if (base::is.null(log)) {
- |
-
| 44 | -14x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 45 | -- |
- }- |
-
| 46 | -- |
- - |
-
| 47 | -27x | -
- if(base::length(NameFile) > 1){
- |
-
| 48 | -1x | -
- NameFile <- NameFile[1]- |
-
| 49 | -1x | -
- log$warn(base::paste0('More than one data file was input. Using only the first: ',NameFile))
- |
-
| 50 | -- |
- }- |
-
| 51 | -- |
- - |
-
| 52 | -- |
- # Pull in as arrow object, retrieve schema, and convert to data frame- |
-
| 53 | -27x | -
- objParq <- arrow::read_parquet(file=NameFile,as_data_frame=FALSE)- |
-
| 54 | -27x | -
- data <- base::data.frame(objParq)- |
-
| 55 | -27x | -
- base::attr(data,'schema') <- objParq$schema- |
-
| 56 | -27x | -
- base::attr(data,'metadata') <- objParq$metadata # Attach any other included metadata- |
-
| 57 | -- | - - | -
| 58 | -- |
- # Assign timezone for POSIX variables- |
-
| 59 | -27x | -
- clssVar <- base::lapply(X=data,FUN=base::class)- |
-
| 60 | -27x | -
- setTime <- base::unlist(base::lapply(X=clssVar,FUN=function(idxClss){base::any(base::grepl(pattern='POSIX',x=idxClss))}))
- |
-
| 61 | -27x | -
- for (idxVar in base::names(data)[setTime]){
- |
-
| 62 | -25x | -
- base::attr(data[[idxVar]],'tzone') <- 'GMT'- |
-
| 63 | -- |
- }- |
-
| 64 | -- |
- - |
-
| 65 | -27x | -
- log$debug(base::paste0('Successfully read in parquet file: ',NameFile, ' to data frame.'))
- |
-
| 66 | -- |
- - |
-
| 67 | -27x | -
- return(data)- |
-
| 68 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Filter named location information by date-time range for NEON instrumented systems sensors- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read named location information (including geolocation history) from JSON file- |
-
| 9 | -- |
- #' for NEON instrumented systems sensor and filter it for a date-time range- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param NameFileIn Filename (including relative or absolute path). Must be json format.- |
-
| 12 | -- |
- #' @param NameFileOut Filename (including relative or absolute path). Must be json format. Defaults to- |
-
| 13 | -- |
- #' NULL, in which case only the filtered json will be returned in list format- |
-
| 14 | -- |
- #' @param TimeBgn POSIX timestamp of the start time (inclusive)- |
-
| 15 | -- |
- #' @param TimeEnd POSIX timestamp of the end time (non-inclusive). Defaults to NULL, in which case the- |
-
| 16 | -- |
- #' location information will be filtered for the exact time of TimeBgn- |
-
| 17 | -- |
- #' @param Prop character vector of the properties in the location file to retain. Defaults to 'all',- |
-
| 18 | -- |
- #' in which all properties of the original file are retained. Include here the names of properties embedded- |
-
| 19 | -- |
- #' at the top level of each location install entry (e.g. "HOR","VER","Data Rate") as well as within the- |
-
| 20 | -- |
- #' "properties" list of each location install entry (e.g. "context","locations","install_date","remove_date",- |
-
| 21 | -- |
- #' "name","site"), as well as within the location_properties entry within "locations"- |
-
| 22 | -- |
- #' (properties:locations:features:properties:location_features list).- |
-
| 23 | -- |
- #' By default, adding "locations" will include geolocation coordinates and offsets to reference locations but- |
-
| 24 | -- |
- #' will not include the "location_properties" list. To include "location_properties", add both "locations"- |
-
| 25 | -- |
- #' and "location_properties" to the Prop argument.- |
-
| 26 | -- |
- #' Note that "location_properties" is not allowed without "locations". If it is included alone, a warning- |
-
| 27 | -- |
- #' will be issued and locations will not be included in the output.- |
-
| 28 | -- |
- #' By default, specifying "location_properties" will include all location properties, which often changes- |
-
| 29 | -- |
- #' in the database as new properties are added. To filter for a particular set of location_properties (if- |
-
| 30 | -- |
- #' they exist), use the syntax "location_properties:<property>", where <property> is the specific item in- |
-
| 31 | -- |
- #' the location_properties list to include. Do not include spaces before or after the ":".- |
-
| 32 | -- |
- #' Example: Prop="location_properties:UTM Zone"- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @return A list of filtered location information. If NameFileOut is specified, the filtered location- |
-
| 35 | -- |
- #' information will also be writted to file in the same json format of NameFileIn- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @references- |
-
| 38 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 39 | -- | - - | -
| 40 | -- |
- #' @keywords Currently none- |
-
| 41 | -- | - - | -
| 42 | -- |
- #' @examples- |
-
| 43 | -- |
- #' TimeBgn <- base::as.POSIXct('2018-01-01',tz='GMT')
- |
-
| 44 | -- |
- #' TimeEnd <- base::as.POSIXct('2018-01-02',tz='GMT')
- |
-
| 45 | -- |
- #' NameFileIn <- 'locations.json'- |
-
| 46 | -- |
- #' NameFileOut <- 'filtered_locations.json'- |
-
| 47 | -- |
- #' loc <- def.loc.filt(NameFileIn,NameFileOut,TimeBgn,TimeEnd)- |
-
| 48 | -- |
- #'- |
-
| 49 | -- |
- #' Filtering for some basics, geolocation history (locations)m and some location properties- |
-
| 50 | -- |
- #' Prop <- c("HOR","VER","install_date","remove_date","name","site","Data Rate","locations","location_properties:UTM Zone","location_properties:TimeTube")
- |
-
| 51 | -- |
- #' loc <- def.loc.filt(NameFileIn,NameFileOut,TimeBgn,TimeEnd,Prop)- |
-
| 52 | -- | - - | -
| 53 | -- | - - | -
| 54 | -- |
- #' @seealso Currently none- |
-
| 55 | -- | - - | -
| 56 | -- |
- #' @export- |
-
| 57 | -- | - - | -
| 58 | -- |
- # changelog and author contributions / copyrights- |
-
| 59 | -- |
- # Cove Sturtevant (2019-07-09)- |
-
| 60 | -- |
- # original creation- |
-
| 61 | -- |
- # Mija Choi (2020-01-14)- |
-
| 62 | -- |
- # Added parameter validations and logging- |
-
| 63 | -- |
- # Mija Choi (2020-01-30)- |
-
| 64 | -- |
- # Added json schema validations- |
-
| 65 | -- |
- # Mija Choi (2020-03-25)- |
-
| 66 | -- |
- # Modified to add a read-only file, inst/extdata/locations-schema.json, in NEONprocIS.base package- |
-
| 67 | -- |
- # Cove Sturtevant (2020-08-19)- |
-
| 68 | -- |
- # Modified filtered output to truncate all relevant dates in the locations file to the- |
-
| 69 | -- |
- # date range of interest (TimeBgn to TimeEnd). Original dates falling between TimeBgn- |
-
| 70 | -- |
- # and TimeEnd will not be modified.- |
-
| 71 | -- |
- # Cove Sturtevant (2021-08-31)- |
-
| 72 | -- |
- # stop execution when schema does not conform- |
-
| 73 | -- |
- # Cove Sturtevant (2023-11-16)- |
-
| 74 | -- |
- # add option to filter for select properties- |
-
| 75 | -- |
- # Cove Sturtevant (2024-07-09)- |
-
| 76 | -- |
- # apply additional sorting of output- |
-
| 77 | -- |
- # Cove Sturtevant (2025-03-20)- |
-
| 78 | -- |
- # fix bug causing failure when there are no items in location_properties- |
-
| 79 | -- |
- # Implement filtering options for location_properties- |
-
| 80 | -- |
- # Add support for filtering new site_location property- |
-
| 81 | -- |
- ##############################################################################################- |
-
| 82 | -- |
- def.loc.filt <- function(NameFileIn,- |
-
| 83 | -- |
- NameFileOut = NULL,- |
-
| 84 | -- |
- TimeBgn,- |
-
| 85 | -- |
- TimeEnd = NULL,- |
-
| 86 | -- |
- Prop = 'all',- |
-
| 87 | -- |
- log = NULL) {
- |
-
| 88 | -- |
- # Initialize log if not input- |
-
| 89 | -16x | -
- if (is.null(log)) {
- |
-
| 90 | -16x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 91 | -- |
- }- |
-
| 92 | -- |
- #- |
-
| 93 | -- |
- # First, validate the syntax of input json to see if it is valid- |
-
| 94 | -- |
- #- |
-
| 95 | -16x | -
- validateJson <-- |
-
| 96 | -16x | -
- NEONprocIS.base::def.validate.json (NameFileIn)- |
-
| 97 | -- |
- #- |
-
| 98 | -- |
- # Second, validate the json against the schema only if the syntax is valid.- |
-
| 99 | -- |
- # Otherwise, validateJsonSchema errors out due to the syntax error- |
-
| 100 | -- |
- #- |
-
| 101 | -- | - - | -
| 102 | -16x | -
- validateJsonSchema <- FALSE- |
-
| 103 | -16x | -
- locJsonSchema <- system.file("extdata", "locations-sensor-schema.json", package="NEONprocIS.base")
- |
-
| 104 | -16x | -
- if (validateJson == TRUE) {
- |
-
| 105 | -13x | -
- validateJsonSchema <-- |
-
| 106 | -13x | -
- NEONprocIS.base::def.validate.json.schema (NameFileIn, locJsonSchema)- |
-
| 107 | -- |
- }- |
-
| 108 | -- |
- - |
-
| 109 | -- |
- #if the validation fails, the function will not be executed- |
-
| 110 | -16x | -
- if ((validateJson == FALSE) || (validateJsonSchema == FALSE))- |
-
| 111 | -- |
- {
- |
-
| 112 | -5x | -
- log$error(- |
-
| 113 | -5x | -
- base::paste0(- |
-
| 114 | -5x | -
- 'In def.loc.filt::: Erred out due to the json validation failure of this file, ',- |
-
| 115 | -5x | -
- NameFileIn- |
-
| 116 | -- |
- )- |
-
| 117 | -- |
- )- |
-
| 118 | -5x | -
- stop("In def.loc.filt::::: Erred out due to the validation failure of the input JSON")
- |
-
| 119 | -- |
- }- |
-
| 120 | -- | - - | -
| 121 | -- |
- # Error check location_properties requests- |
-
| 122 | -11x | -
- setParaLocProp <- base::grepl("location_properties",Prop)
- |
-
| 123 | -11x | -
- if (base::any(setParaLocProp) && !("locations" %in% Prop)){
- |
-
| 124 | -! | -
- log$warn("'location_properties' is included in the Prop parameter, but without also specifying 'locations'. No location_properties will be included in the output")
- |
-
| 125 | -! | -
- Prop <- Prop[!setParaLocProp]- |
-
| 126 | -- |
- }- |
-
| 127 | -- |
- - |
-
| 128 | -- |
- # Error check location_properties requests- |
-
| 129 | -11x | -
- setParaLocProp <- base::grepl("location_properties",Prop)
- |
-
| 130 | -11x | -
- LocProp <- c()- |
-
| 131 | -11x | -
- if (any(setParaLocProp)){
- |
-
| 132 | -1x | -
- ParaLocPropSplt <- base::strsplit(Prop[setParaLocProp],':')- |
-
| 133 | -1x | -
- LocProp <- base::unlist(- |
-
| 134 | -1x | -
- base::lapply(ParaLocPropSplt,FUN=function(locPropIdx){
- |
-
| 135 | -2x | -
- if(length(locPropIdx) > 1){
- |
-
| 136 | -2x | -
- return(locPropIdx[2])- |
-
| 137 | -- |
- } else {
- |
-
| 138 | -! | -
- return(NULL)- |
-
| 139 | -- |
- }- |
-
| 140 | -- |
- })- |
-
| 141 | -- |
- )- |
-
| 142 | -- |
- }- |
-
| 143 | -- | - - | -
| 144 | -- |
- # Run the code when the input json is correct syntactically and valid against the schema- |
-
| 145 | -11x | -
- FmtTime <- '%Y-%m-%dT%H:%M:%SZ' # Time format in the location file- |
-
| 146 | -- |
- - |
-
| 147 | -- |
- # If NULL, set TimeEnd to 1 second after TimeBgn- |
-
| 148 | -11x | -
- if (base::is.null(TimeEnd)) {
- |
-
| 149 | -1x | -
- TimeEnd <- TimeBgn + as.difftime(1, units = 'secs')- |
-
| 150 | -- |
- }- |
-
| 151 | -- |
- - |
-
| 152 | -- |
- # Get formatted character representations of the start and end times- |
-
| 153 | -11x | -
- TimeBgnFmt <- base::format(TimeBgn,format=FmtTime)- |
-
| 154 | -11x | -
- TimeEndFmt <- base::format(TimeEnd,format=FmtTime)- |
-
| 155 | -- |
- - |
-
| 156 | -- |
- # Load in the raw json info- |
-
| 157 | -11x | -
- loc <- rjson::fromJSON(file = NameFileIn, simplify = FALSE)- |
-
| 158 | -- |
- - |
-
| 159 | -- |
- # Filter the named locations- |
-
| 160 | -11x | -
- setKeepLoc <- base::numeric(0)- |
-
| 161 | -11x | -
- for (idxLoc in base::seq_len(length(loc$features))) {
- |
-
| 162 | -15x | -
- timeInst <- loc$features[[idxLoc]]$properties$install_date- |
-
| 163 | -15x | -
- if (!base::is.null(timeInst)) {
- |
-
| 164 | -15x | -
- timeInst <-- |
-
| 165 | -15x | -
- base::as.POSIXct(timeInst, format = FmtTime, tz = 'GMT')- |
-
| 166 | -- |
- }- |
-
| 167 | -15x | -
- timeRmv <- loc$features[[idxLoc]]$properties$remove_date- |
-
| 168 | -15x | -
- if (!base::is.null(timeRmv)) {
- |
-
| 169 | -8x | -
- timeRmv <-- |
-
| 170 | -8x | -
- base::as.POSIXct(timeRmv, format = FmtTime, tz = 'GMT')- |
-
| 171 | -- |
- }- |
-
| 172 | -- |
- - |
-
| 173 | -15x | -
- if ((timeInst < TimeEnd) &&- |
-
| 174 | -15x | -
- (base::is.null(timeRmv) || (timeRmv > TimeBgn))) {
- |
-
| 175 | -- |
- # Mark this location to keep (it applies to this day)- |
-
| 176 | -13x | -
- setKeepLoc <- c(setKeepLoc, idxLoc)- |
-
| 177 | -- |
- - |
-
| 178 | -- |
- # Truncate the install and remove dates to the start & end times, so that any- |
-
| 179 | -- |
- # upstream changes outside TimeBgn and TimeEnd are indistinguishable in- |
-
| 180 | -- |
- # downstream processing- |
-
| 181 | -13x | -
- if(timeInst < TimeBgn){
- |
-
| 182 | -1x | -
- loc$features[[idxLoc]]$properties$install_date <- TimeBgnFmt- |
-
| 183 | -- |
- }- |
-
| 184 | -13x | -
- if(base::is.null(timeRmv) || (timeRmv > TimeEnd)){
- |
-
| 185 | -8x | -
- loc$features[[idxLoc]]$properties$remove_date <- TimeEndFmt- |
-
| 186 | -- |
- }- |
-
| 187 | -- |
- - |
-
| 188 | -- |
- # Sort the top level and properties list- |
-
| 189 | -13x | -
- loc$features[[idxLoc]] <- loc$features[[idxLoc]][sort(names(loc$features[[idxLoc]]))] # Top level- |
-
| 190 | -13x | -
- loc$features[[idxLoc]]$properties <- loc$features[[idxLoc]]$properties[sort(names(loc$features[[idxLoc]]$properties))] # Properties list- |
-
| 191 | -- |
- }- |
-
| 192 | -- |
- }- |
-
| 193 | -11x | -
- loc$features <- loc$features[setKeepLoc]- |
-
| 194 | -- |
- - |
-
| 195 | -- |
- # If setKeepLoc is empty, we're done. No applicable location information- |
-
| 196 | -11x | -
- if (base::length(setKeepLoc) == 0) {
- |
-
| 197 | -1x | -
- base::write(rjson::toJSON(loc, indent = 3), file = NameFileOut)- |
-
| 198 | -1x | -
- return(loc)- |
-
| 199 | -- |
- }- |
-
| 200 | -- |
- - |
-
| 201 | -- |
- - |
-
| 202 | -- |
- # Filter for particular properties- |
-
| 203 | -10x | -
- if(!('all' %in% Prop)){
- |
-
| 204 | -2x | -
- for (idxLoc in base::seq_len(base::length(loc$features))) {
- |
-
| 205 | -- |
- # Traverse top level- |
-
| 206 | -2x | -
- locIdx <- loc$features[[idxLoc]]- |
-
| 207 | -2x | -
- nameProp <- base::names(locIdx)- |
-
| 208 | -2x | -
- setKeep <- nameProp %in% c('properties','geometry',Prop)
- |
-
| 209 | -2x | -
- locIdx <- locIdx[sort(nameProp[setKeep])] # Also sort to ensure a change in ordering of properties in file results in the same output- |
-
| 210 | -- |
- - |
-
| 211 | -- |
- # Descend into "properties"- |
-
| 212 | -2x | -
- locIdxProp <- locIdx$properties- |
-
| 213 | -2x | -
- nameProp <- base::names(locIdxProp)- |
-
| 214 | -2x | -
- setKeep <- nameProp %in% Prop- |
-
| 215 | -2x | -
- locIdxProp <- locIdxProp[sort(nameProp[setKeep])] # Also sort to ensure a change in ordering of properties in file results in the same output- |
-
| 216 | -- |
- - |
-
| 217 | -- |
- # Put filtered set back into master list- |
-
| 218 | -2x | -
- locIdx$properties <- locIdxProp- |
-
| 219 | -2x | -
- loc$features[[idxLoc]] <- locIdx- |
-
| 220 | -- |
- }- |
-
| 221 | -- |
- }- |
-
| 222 | -- |
- - |
-
| 223 | -- |
- - |
-
| 224 | -- |
- # For each applicable named location, filter its geolocation date ranges- |
-
| 225 | -10x | -
- if (any(c('all','locations','site_location') %in% Prop)) {
- |
-
| 226 | -9x | -
- for (idxLoc in base::seq_len(base::length(loc$features))) {
- |
-
| 227 | -- |
- - |
-
| 228 | -- |
- # Filter geolocations for both the installed NL as well as the site_locations also included (if site_locations is to be output)- |
-
| 229 | -12x | -
- for (locGeoType in c('install','site')){
- |
-
| 230 | -24x | -
- if(locGeoType == 'install'){
- |
-
| 231 | -12x | -
- if(any(c('all','locations') %in% Prop)){
- |
-
| 232 | -12x | -
- locGeo <- loc$features[[idxLoc]]$properties$locations$features- |
-
| 233 | -- |
- } else {
- |
-
| 234 | -! | -
- next- |
-
| 235 | -- |
- }- |
-
| 236 | -12x | -
- } else if (locGeoType == 'site'){
- |
-
| 237 | -12x | -
- if(any(c('all','site_location') %in% Prop)){
- |
-
| 238 | -11x | -
- locGeo <- loc$features[[idxLoc]]$properties$site_location$features- |
-
| 239 | -- |
- } else {
- |
-
| 240 | -1x | -
- next- |
-
| 241 | -- |
- }- |
-
| 242 | -- |
- }- |
-
| 243 | -- | - - | -
| 244 | -- |
- # Filter the geolocations- |
-
| 245 | -23x | -
- setKeepGeo <- base::numeric(0)- |
-
| 246 | -23x | -
- for (idxGeo in base::seq_len(base::length(locGeo))) {
- |
-
| 247 | -18x | -
- timeBgnGeo <- locGeo[[idxGeo]]$properties$start_date- |
-
| 248 | -18x | -
- if (!base::is.null(timeBgnGeo)) {
- |
-
| 249 | -18x | -
- timeBgnGeo <-- |
-
| 250 | -18x | -
- base::as.POSIXct(timeBgnGeo, format = FmtTime, tz = 'GMT')- |
-
| 251 | -- |
- }- |
-
| 252 | -18x | -
- timeEndGeo <- locGeo[[idxGeo]]$properties$end_date- |
-
| 253 | -18x | -
- if (!base::is.null(timeEndGeo)) {
- |
-
| 254 | -5x | -
- timeEndGeo <-- |
-
| 255 | -5x | -
- base::as.POSIXct(timeEndGeo, format = FmtTime, tz = 'GMT')- |
-
| 256 | -- |
- }- |
-
| 257 | -- |
- - |
-
| 258 | -18x | -
- if ((timeBgnGeo < TimeEnd) &&- |
-
| 259 | -18x | -
- (base::is.null(timeEndGeo) ||- |
-
| 260 | -18x | -
- (timeEndGeo > TimeBgn))) {
- |
-
| 261 | -17x | -
- setKeepGeo <- c(setKeepGeo, idxGeo)- |
-
| 262 | -- |
- - |
-
| 263 | -- |
- # Truncate the start and end dates to the time range we are interested in, so that any- |
-
| 264 | -- |
- # upstream changes outside TimeBgn and TimeEnd are indistinguishable in- |
-
| 265 | -- |
- # downstream processing- |
-
| 266 | -17x | -
- if(timeBgnGeo < TimeBgn){
- |
-
| 267 | -12x | -
- locGeo[[idxGeo]]$properties$start_date <- TimeBgnFmt- |
-
| 268 | -- |
- }- |
-
| 269 | -17x | -
- if(base::is.null(timeEndGeo) || (timeEndGeo > TimeEnd)){
- |
-
| 270 | -13x | -
- locGeo[[idxGeo]]$properties$end_date <- TimeEndFmt- |
-
| 271 | -- |
- }- |
-
| 272 | -- |
- - |
-
| 273 | -- |
- # Sort the top level feature list, properties and nested location_properties. For some reason, these reorder in the database call sometimes- |
-
| 274 | -17x | -
- locGeo[[idxGeo]] <- locGeo[[idxGeo]][sort(names(locGeo[[idxGeo]]))]- |
-
| 275 | -17x | -
- locGeo[[idxGeo]]$properties <- locGeo[[idxGeo]]$properties[sort(base::names(locGeo[[idxGeo]]$properties))]- |
-
| 276 | -17x | -
- if('location_properties' %in% base::names(locGeo[[idxGeo]]$properties)){
- |
-
| 277 | -- |
- - |
-
| 278 | -- |
- # Do we want any location_properties?- |
-
| 279 | -3x | -
- if(length(LocProp) > 0 || any(c("all","location_properties") %in% Prop)){
- |
-
| 280 | -- |
- - |
-
| 281 | -3x | -
- if (length(LocProp) > 0){
- |
-
| 282 | -- |
- # We only want specific properties. Filter.- |
-
| 283 | -1x | -
- itemGeoProp <- locGeo[[idxGeo]]$properties$location_properties- |
-
| 284 | -1x | -
- nameItem <- base::unlist(base::lapply(itemGeoProp,FUN=function(idxList){idxList[1]}))
- |
-
| 285 | -1x | -
- setGeoPropKeep <- nameItem %in% LocProp- |
-
| 286 | -1x | -
- locGeo[[idxGeo]]$properties$location_properties <- itemGeoProp[setGeoPropKeep]- |
-
| 287 | -- |
- }- |
-
| 288 | -- |
- - |
-
| 289 | -- |
- # Sort- |
-
| 290 | -3x | -
- itemGeoProp <- locGeo[[idxGeo]]$properties$location_properties- |
-
| 291 | -3x | -
- nameItem <- base::unlist(base::lapply(itemGeoProp,FUN=function(idxList){idxList[1]}))
- |
-
| 292 | -3x | -
- if(base::length(nameItem) > 1){
- |
-
| 293 | -3x | -
- idxSortItem <- sort(nameItem,index.return=TRUE)$ix- |
-
| 294 | -3x | -
- locGeo[[idxGeo]]$properties$location_properties <- locGeo[[idxGeo]]$properties$location_properties[idxSortItem]- |
-
| 295 | -- |
- }- |
-
| 296 | -- |
- - |
-
| 297 | -- |
- } else {
- |
-
| 298 | -- |
- # We don't want any location_properties. Remove the entire entry- |
-
| 299 | -! | -
- locGeo[[idxGeo]]$properties['location_properties'] <- NULL- |
-
| 300 | -- |
- - |
-
| 301 | -- |
- }- |
-
| 302 | -- |
- }- |
-
| 303 | -- |
- - |
-
| 304 | -- |
- } else {
- |
-
| 305 | -- |
- # We're deleting this geolocation, let's move on- |
-
| 306 | -1x | -
- next- |
-
| 307 | -- |
- }- |
-
| 308 | -- |
- - |
-
| 309 | -- |
- # Now filter the reference location geolocations (if there are any). Note that the reference locations- |
-
| 310 | -- |
- # can have a chain of their own reference locations. We're going to navigate through them, marking those for- |
-
| 311 | -- |
- # deletion at the end of the while loop- |
-
| 312 | -17x | -
- locGeoRef00 <-- |
-
| 313 | -17x | -
- locGeo[[idxGeo]]$properties$reference_location # Initialize- |
-
| 314 | -17x | -
- idxGeoRef <- 1- |
-
| 315 | -17x | -
- setRmvGeoRef <- base::list()- |
-
| 316 | -17x | -
- cont <- TRUE- |
-
| 317 | -- |
- - |
-
| 318 | -- |
- # Sort the properties- |
-
| 319 | -17x | -
- locGeoRef00$properties <- locGeoRef00$properties[sort(names(locGeoRef00$properties))]- |
-
| 320 | -- |
- - |
-
| 321 | -17x | -
- while (cont) {
- |
-
| 322 | -- |
- # Get the parent of our current level- |
-
| 323 | -50x | -
- numLvl <- base::length(idxGeoRef)- |
-
| 324 | -50x | -
- if (numLvl == 1) {
- |
-
| 325 | -40x | -
- txtEval <- 'locGeoRef00$properties$locations$features'- |
-
| 326 | -10x | -
- } else if (numLvl == 2) {
- |
-
| 327 | -6x | -
- txtEval <-- |
-
| 328 | -6x | -
- base::paste0(- |
-
| 329 | -6x | -
- 'locGeoRef00$properties$locations$features[[',- |
-
| 330 | -6x | -
- idxGeoRef[1],- |
-
| 331 | -- |
- ']]',- |
-
| 332 | -6x | -
- base::paste0(- |
-
| 333 | -6x | -
- '$properties$reference_location$properties$locations$features',- |
-
| 334 | -6x | -
- collapse = ''- |
-
| 335 | -- |
- )- |
-
| 336 | -- |
- )- |
-
| 337 | -- |
- } else {
- |
-
| 338 | -4x | -
- txtEval <-- |
-
| 339 | -4x | -
- base::paste0(- |
-
| 340 | -4x | -
- 'locGeoRef00$properties$locations$features[[',- |
-
| 341 | -4x | -
- idxGeoRef[1],- |
-
| 342 | -- |
- ']]',- |
-
| 343 | -4x | -
- base::paste0(- |
-
| 344 | -4x | -
- '$properties$reference_location$properties$locations$features[[',- |
-
| 345 | -4x | -
- idxGeoRef[2:(length(idxGeoRef) - 1)],- |
-
| 346 | -- |
- ']]',- |
-
| 347 | -4x | -
- collapse = ''- |
-
| 348 | -- |
- ),- |
-
| 349 | -4x | -
- '$properties$reference_location$properties$locations$features'- |
-
| 350 | -- |
- )- |
-
| 351 | -- |
- }- |
-
| 352 | -50x | -
- locRefPrnt <- base::eval(parse(text = txtEval))- |
-
| 353 | -- |
- - |
-
| 354 | -- |
- # How many geolocs do we have ?- |
-
| 355 | -50x | -
- numGeoRef <- base::length(locRefPrnt)- |
-
| 356 | -- |
- - |
-
| 357 | -- |
- # Check whether we are beyond the end of reference geolocations at this level- |
-
| 358 | -50x | -
- if (utils::tail(idxGeoRef, 1) > numGeoRef) {
- |
-
| 359 | -- |
- # Back out a level, increment the index- |
-
| 360 | -22x | -
- idxGeoRef <- idxGeoRef[-length(idxGeoRef)]- |
-
| 361 | -22x | -
- if (base::length(idxGeoRef) == 0) {
- |
-
| 362 | -- |
- # We've gone through the entire hierarchy. We're done.- |
-
| 363 | -17x | -
- cont <- FALSE- |
-
| 364 | -17x | -
- next- |
-
| 365 | -- |
- } else {
- |
-
| 366 | -5x | -
- idxGeoRef[length(idxGeoRef)] <-- |
-
| 367 | -5x | -
- utils::tail(idxGeoRef, 1) + 1 # increment index- |
-
| 368 | -5x | -
- next- |
-
| 369 | -- |
- }- |
-
| 370 | -- |
- }- |
-
| 371 | -- |
- - |
-
| 372 | -- |
- # Set locGeoRef to the data at our current level- |
-
| 373 | -28x | -
- if (base::length(idxGeoRef) > 1) {
- |
-
| 374 | -5x | -
- txtEval <-- |
-
| 375 | -5x | -
- base::paste0(- |
-
| 376 | -5x | -
- 'locGeoRef00$properties$locations$features[[',- |
-
| 377 | -5x | -
- idxGeoRef[1],- |
-
| 378 | -- |
- ']]',- |
-
| 379 | -5x | -
- base::paste0(- |
-
| 380 | -5x | -
- '$properties$reference_location$properties$locations$features[[',- |
-
| 381 | -5x | -
- idxGeoRef[-1],- |
-
| 382 | -- |
- ']]',- |
-
| 383 | -5x | -
- collapse = ''- |
-
| 384 | -- |
- )- |
-
| 385 | -- |
- )- |
-
| 386 | -- |
- } else {
- |
-
| 387 | -23x | -
- txtEval <-- |
-
| 388 | -23x | -
- base::paste0('locGeoRef00$properties$locations$features[[',
- |
-
| 389 | -23x | -
- idxGeoRef[1],- |
-
| 390 | -- |
- ']]')- |
-
| 391 | -- |
- }- |
-
| 392 | -28x | -
- locGeoRef <- base::eval(parse(text = txtEval))- |
-
| 393 | -- |
- - |
-
| 394 | -- |
- # Check date range of geolocation- |
-
| 395 | -28x | -
- timeBgnGeoRef <- locGeoRef$properties$start_date- |
-
| 396 | -28x | -
- if (!base::is.null(timeBgnGeoRef)) {
- |
-
| 397 | -28x | -
- timeBgnGeoRef <-- |
-
| 398 | -28x | -
- base::as.POSIXct(timeBgnGeoRef, format = FmtTime, tz = 'GMT')- |
-
| 399 | -- |
- }- |
-
| 400 | -28x | -
- timeEndGeoRef <- locGeoRef$properties$end_date- |
-
| 401 | -28x | -
- if (!base::is.null(timeEndGeoRef)) {
- |
-
| 402 | -10x | -
- timeEndGeoRef <-- |
-
| 403 | -10x | -
- base::as.POSIXct(timeEndGeoRef, format = FmtTime, tz = 'GMT')- |
-
| 404 | -- |
- }- |
-
| 405 | -- |
- - |
-
| 406 | -- |
- # If this geoloc date range is outside our day, mark for deletion and move on- |
-
| 407 | -28x | -
- if ((timeBgnGeoRef > TimeEnd) ||- |
-
| 408 | -28x | -
- (!base::is.null(timeEndGeoRef) &&- |
-
| 409 | -28x | -
- timeEndGeoRef < TimeBgn)) {
- |
-
| 410 | -3x | -
- setRmvGeoRef[[base::length(setRmvGeoRef) + 1]] <- idxGeoRef- |
-
| 411 | -- |
- - |
-
| 412 | -- |
- # Move on. We don't need to dive further into reference locations for this geoloc- |
-
| 413 | -3x | -
- idxGeoRef[base::length(idxGeoRef)] <-- |
-
| 414 | -3x | -
- utils::tail(idxGeoRef, 1) + 1- |
-
| 415 | -3x | -
- next- |
-
| 416 | -- |
- - |
-
| 417 | -- |
- } else {
- |
-
| 418 | -- |
- # Truncate the start and end dates to the time range we are interested in, so that any- |
-
| 419 | -- |
- # upstream changes outside TimeBgn and TimeEnd are indistinguishable in- |
-
| 420 | -- |
- # downstream processing- |
-
| 421 | -25x | -
- if(timeBgnGeoRef < TimeBgn){
- |
-
| 422 | -14x | -
- txtTimeEval <- base::paste0(txtEval,'$properties$start_date <- TimeBgnFmt')- |
-
| 423 | -14x | -
- base::eval(parse(text = txtTimeEval))- |
-
| 424 | -- |
- }- |
-
| 425 | -25x | -
- if(base::is.null(timeEndGeoRef) || (timeEndGeoRef > TimeEnd)){
- |
-
| 426 | -17x | -
- txtTimeEval <- base::paste0(txtEval,'$properties$end_date <- TimeEndFmt')- |
-
| 427 | -17x | -
- base::eval(parse(text = txtTimeEval))- |
-
| 428 | -- |
- }- |
-
| 429 | -- |
- - |
-
| 430 | -- |
- # Sort the properties and nested location_properties to ensure consistent output- |
-
| 431 | -25x | -
- txtPropSortEval <- base::paste0(txtEval,'$properties <- ',txtEval,'$properties[sort(base::names(',txtEval,'$properties))]')
- |
-
| 432 | -25x | -
- base::eval(parse(text = txtPropSortEval))- |
-
| 433 | -25x | -
- txtItemGeoProp <- base::paste0('itemGeoProp <- ',txtEval,'$properties$location_properties')
- |
-
| 434 | -25x | -
- base::eval(parse(text = txtItemGeoProp))- |
-
| 435 | -25x | -
- if(!base::is.null(itemGeoProp)){
- |
-
| 436 | -- |
- - |
-
| 437 | -- |
- - |
-
| 438 | -- |
- - |
-
| 439 | -- |
- # Do we want any location_properties?- |
-
| 440 | -2x | -
- if(length(LocProp) > 0 || any(c("all","location_properties") %in% Prop)){
- |
-
| 441 | -- |
- - |
-
| 442 | -2x | -
- if (length(LocProp) > 0){
- |
-
| 443 | -- |
- # We only want specific properties. Filter.- |
-
| 444 | -10x | -
- nameItem <- base::unlist(base::lapply(itemGeoProp,FUN=function(idxList){idxList[1]}))
- |
-
| 445 | -1x | -
- setGeoPropKeep <- nameItem %in% LocProp- |
-
| 446 | -1x | -
- txtItemGeoKeep <- base::paste0(txtEval,'$properties$location_properties <- itemGeoProp[setGeoPropKeep]')- |
-
| 447 | -1x | -
- base::eval(parse(text = txtItemGeoKeep))- |
-
| 448 | -- |
- }- |
-
| 449 | -- |
- - |
-
| 450 | -- |
- # Sort- |
-
| 451 | -2x | -
- txtItemGeoProp <- base::paste0('itemGeoProp <- ',txtEval,'$properties$location_properties')
- |
-
| 452 | -2x | -
- base::eval(parse(text = txtItemGeoProp))- |
-
| 453 | -12x | -
- nameItem <- base::unlist(base::lapply(itemGeoProp,FUN=function(idxList){idxList[1]}))
- |
-
| 454 | -2x | -
- if(base::length(nameItem) > 1){
- |
-
| 455 | -2x | -
- idxSortItem <- sort(nameItem,index.return=TRUE)$ix- |
-
| 456 | -2x | -
- txtItemGeoSort <- base::paste0(txtEval,'$properties$location_properties <- itemGeoProp[idxSortItem]')- |
-
| 457 | -2x | -
- base::eval(parse(text = txtItemGeoSort))- |
-
| 458 | -- |
- }- |
-
| 459 | -- |
- - |
-
| 460 | -- |
- } else {
- |
-
| 461 | -- |
- # We don't want any location_properties. Remove the entire entry- |
-
| 462 | -! | -
- txtItemGeoRmv <- base::paste0(txtEval,"$properties['location_properties'] <- NULL")- |
-
| 463 | -! | -
- base::eval(parse(text = txtItemGeoRmv))- |
-
| 464 | -- |
- - |
-
| 465 | -- |
- }- |
-
| 466 | -- |
- }- |
-
| 467 | -- |
- }- |
-
| 468 | -- |
- - |
-
| 469 | -- |
- # Are there more reference locations?- |
-
| 470 | -25x | -
- if (base::length(- |
-
| 471 | -25x | -
- locGeoRef$properties$reference_location$properties$locations$features- |
-
| 472 | -25x | -
- ) != 0) {
- |
-
| 473 | -- |
- # Go a level deeper- |
-
| 474 | -5x | -
- idxGeoRef <- c(idxGeoRef, 1)- |
-
| 475 | -5x | -
- next- |
-
| 476 | -- |
- - |
-
| 477 | -- |
- } else {
- |
-
| 478 | -- |
- # We found the end of the reference chain! Let's move on to the next geolocation at this same level.- |
-
| 479 | -20x | -
- idxGeoRef[base::length(idxGeoRef)] <-- |
-
| 480 | -20x | -
- utils::tail(idxGeoRef, 1) + 1- |
-
| 481 | -- |
- - |
-
| 482 | -- |
- }- |
-
| 483 | -17x | -
- } # End loop around reference locations- |
-
| 484 | -- |
- - |
-
| 485 | -- |
- # Remove reference geolocations marked for deletion- |
-
| 486 | -17x | -
- setRmvGeoRef <- base::rev(setRmvGeoRef) # Reverse order so we go from the bottom- |
-
| 487 | -17x | -
- for (idxRmv in base::seq_len(base::length(setRmvGeoRef))) {
- |
-
| 488 | -3x | -
- idxGeoRef <- setRmvGeoRef[[idxRmv]]- |
-
| 489 | -- |
- - |
-
| 490 | -- |
- # Formulate the list path- |
-
| 491 | -3x | -
- if (base::length(idxGeoRef) > 1) {
- |
-
| 492 | -! | -
- txtEval <-- |
-
| 493 | -! | -
- base::paste0(- |
-
| 494 | -! | -
- 'locGeoRef00$properties$locations$features[[',- |
-
| 495 | -! | -
- idxGeoRef[1],- |
-
| 496 | -- |
- ']]',- |
-
| 497 | -! | -
- base::paste0(- |
-
| 498 | -! | -
- '$properties$reference_location$properties$locations$features[[',- |
-
| 499 | -! | -
- idxGeoRef[-1],- |
-
| 500 | -- |
- ']]',- |
-
| 501 | -! | -
- collapse = ''- |
-
| 502 | -- |
- ),- |
-
| 503 | -! | -
- ' <- NULL'- |
-
| 504 | -- |
- )- |
-
| 505 | -- |
- } else {
- |
-
| 506 | -3x | -
- txtEval <-- |
-
| 507 | -3x | -
- base::paste0(- |
-
| 508 | -3x | -
- 'locGeoRef00$properties$locations$features[[',- |
-
| 509 | -3x | -
- idxGeoRef[1],- |
-
| 510 | -3x | -
- ']] <- NULL'- |
-
| 511 | -- |
- )- |
-
| 512 | -- |
- }- |
-
| 513 | -3x | -
- base::eval(parse(text = txtEval))- |
-
| 514 | -- |
- - |
-
| 515 | -- |
- }- |
-
| 516 | -- |
- - |
-
| 517 | -- |
- # Insert filtered reference locations back into the geolocation information- |
-
| 518 | -17x | -
- if(base::is.null(locGeoRef00) && 'reference_location' %in% base::names(locGeo[[idxGeo]]$properties)){
- |
-
| 519 | -- |
- # Cover the scenario where the first reference location is listed as null in the location file- |
-
| 520 | -1x | -
- locGeo[[idxGeo]]$properties['reference_location'] <- base::list(NULL)- |
-
| 521 | -- |
- } else {
- |
-
| 522 | -16x | -
- locGeo[[idxGeo]]$properties$reference_location <- locGeoRef00- |
-
| 523 | -- |
- }- |
-
| 524 | -- |
- - |
-
| 525 | -- |
- - |
-
| 526 | -- |
- } # end loop around geolocations- |
-
| 527 | -- |
- - |
-
| 528 | -- |
- # Keep only applicable geolocations- |
-
| 529 | -23x | -
- locGeo <- locGeo[setKeepGeo]- |
-
| 530 | -- |
- - |
-
| 531 | -23x | -
- if(locGeoType == 'install'){
- |
-
| 532 | -12x | -
- loc$features[[idxLoc]]$properties$locations$features <- locGeo- |
-
| 533 | -11x | -
- } else if (locGeoType == 'site'){
- |
-
| 534 | -11x | -
- loc$features[[idxLoc]]$properties$site_location$features <- locGeo- |
-
| 535 | -- |
- }- |
-
| 536 | -- |
- - |
-
| 537 | -- |
- - |
-
| 538 | -- |
- - |
-
| 539 | -- |
- } # End loop around install vs. site_location- |
-
| 540 | -- |
- } # End loop around named locations- |
-
| 541 | -- |
- }- |
-
| 542 | -- | - - | -
| 543 | -- |
- - |
-
| 544 | -10x | -
- log$debug('Sensor location file filtered successfully.')
- |
-
| 545 | -- |
- - |
-
| 546 | -- |
- # Write to file- |
-
| 547 | -10x | -
- if (!base::is.null(NameFileOut)) {
- |
-
| 548 | -10x | -
- base::write(rjson::toJSON(loc, indent = 4), file = NameFileOut)- |
-
| 549 | -10x | -
- log$debug(base::paste0('Filtered sensor location file written successfully to ',NameFileOut))
- |
-
| 550 | -- |
- }- |
-
| 551 | -- |
- - |
-
| 552 | -10x | -
- return(loc)- |
-
| 553 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Identify any inconsistent or corrupt timeseries records across a set of files- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Given a set of file paths containing timeseries data, identify any timestamps- |
-
| 9 | -- |
- #' that are not consistently present across all files. Also identify any records that contain NA- |
-
| 10 | -- |
- #' values.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param nameFile Character vector of any length, consisting of the full or relative paths to all- |
-
| 13 | -- |
- #' the data files to evaluate together for consistent timestamps and any NA-containing records. The- |
-
| 14 | -- |
- #' files must be avro or parquet files containing tabular data. These files will be read by- |
-
| 15 | -- |
- #' NEONprocIS.base::def.read.avro.deve or NEONprocIS.base::def.read.parq, which will return a data frame.- |
-
| 16 | -- |
- #' One column of the data frame must be readout_time.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 19 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @return A list of \code{timeAll} and \code{timeBad}, each data frames with one column:
- |
-
| 22 | -- |
- #' \code{readout_time} POSIXct timestamps signifying... for timeAll) the union of all encountered
- |
-
| 23 | -- |
- #' timestamps across the set of input files, and for timeBad) inconsistent or corrupt (NA-containing)- |
-
| 24 | -- |
- #' records across the set of input files- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @references Currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @keywords Currently none- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @examples- |
-
| 31 | -- |
- #' NEONprocIS.base::def.rcd.miss.na(nameFile=c('/path/to/file1.avro','/another/path/to/file2.avro'))
- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.avro.deve}
- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @export- |
-
| 36 | -- | - - | -
| 37 | -- |
- # changelog and author contributions / copyrights- |
-
| 38 | -- |
- # Cove Sturtevant (2020-03-04)- |
-
| 39 | -- |
- # original creation- |
-
| 40 | -- |
- ##############################################################################################- |
-
| 41 | -- |
- def.rcd.miss.na <- function(fileData,log = NULL) {
- |
-
| 42 | -- |
- #browser()- |
-
| 43 | -- |
- # initialize logging if necessary- |
-
| 44 | -7x | -
- if (base::is.null(log)) {
- |
-
| 45 | -7x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 46 | -- |
- }- |
-
| 47 | -- |
- - |
-
| 48 | -- |
- # Go through each sensor data file, looking for inconsistent timestamps and NA values- |
-
| 49 | -7x | -
- timeDmmy <- base::as.POSIXct(base::character(0)) # Initialize- |
-
| 50 | -7x | -
- timeBad <- base::data.frame(readout_time=timeDmmy,stringsAsFactors = FALSE) # Initialize- |
-
| 51 | -7x | -
- for(idxFile in fileData){
- |
-
| 52 | -- |
- - |
-
| 53 | -- |
- # What format?- |
-
| 54 | -11x | -
- fmt <- utils::tail(base::strsplit(idxFile,'[.]')[[1]],1)- |
-
| 55 | -- |
- - |
-
| 56 | -- |
- # Load in file- |
-
| 57 | -11x | -
- if (fmt == 'avro') {
- |
-
| 58 | -1x | -
- data <-- |
-
| 59 | -1x | -
- base::try(NEONprocIS.base::def.read.avro.deve(NameFile = idxFile,- |
-
| 60 | -1x | -
- NameLib = '/ravro.so',- |
-
| 61 | -1x | -
- log = log),- |
-
| 62 | -1x | -
- silent = FALSE)- |
-
| 63 | -10x | -
- } else if (fmt == 'parquet') {
- |
-
| 64 | -9x | -
- data <-- |
-
| 65 | -9x | -
- base::try(NEONprocIS.base::def.read.parq(NameFile = idxFile, log = log),- |
-
| 66 | -9x | -
- silent = FALSE)- |
-
| 67 | -- |
- } else {
- |
-
| 68 | -1x | -
- log$error(- |
-
| 69 | -1x | -
- base::paste0(- |
-
| 70 | -1x | -
- 'Cannot determine file type for ',- |
-
| 71 | -1x | -
- idxFile,- |
-
| 72 | -1x | -
- '. Extension must be .avro or .parquet.'- |
-
| 73 | -- |
- )- |
-
| 74 | -- |
- )- |
-
| 75 | -1x | -
- stop()- |
-
| 76 | -- |
- }- |
-
| 77 | -- |
- - |
-
| 78 | -10x | -
- if (base::class(data) == 'try-error') {
- |
-
| 79 | -- |
- # Generate error and stop execution- |
-
| 80 | -1x | -
- log$error(base::paste0('File ', idxFile, ' is unreadable.'))
- |
-
| 81 | -1x | -
- base::stop()- |
-
| 82 | -- |
- }- |
-
| 83 | -9x | -
- chkCol <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNa=FALSE,TestNumc=FALSE,TestNameCol = 'readout_time',log=log)- |
-
| 84 | -9x | -
- if(!chkCol){
- |
-
| 85 | -1x | -
- stop()- |
-
| 86 | -- |
- }- |
-
| 87 | -- |
- - |
-
| 88 | -- |
- - |
-
| 89 | -- |
- # Initialize if reading the first file- |
-
| 90 | -8x | -
- if(idxFile == fileData[1]){
- |
-
| 91 | -4x | -
- timeAll <- base::data.frame(readout_time=data$readout_time,stringsAsFactors = FALSE)- |
-
| 92 | -- |
- }- |
-
| 93 | -- |
- - |
-
| 94 | -- |
- # Check for extra times- |
-
| 95 | -8x | -
- timeXtra <- base::subset(data,subset=!(data$readout_time %in% timeAll$readout_time),select='readout_time')- |
-
| 96 | -- |
- - |
-
| 97 | -- |
- # Check for missing times- |
-
| 98 | -8x | -
- timeMiss <- base::subset(timeAll,subset=!(timeAll$readout_time %in% data$readout_time),select='readout_time')- |
-
| 99 | -- |
- - |
-
| 100 | -- |
- # Add extra or missing times to list of bad timestamps- |
-
| 101 | -8x | -
- timeBad <- base::rbind(timeBad,timeXtra,timeMiss)- |
-
| 102 | -- |
- - |
-
| 103 | -- |
- # Search for timestamps associated with NA values in any column- |
-
| 104 | -8x | -
- setNa <-- |
-
| 105 | -8x | -
- base::unique(base::unlist(base::lapply(- |
-
| 106 | -8x | -
- base::subset(data, select = -readout_time),- |
-
| 107 | -8x | -
- FUN = function(colData) {
- |
-
| 108 | -15x | -
- base::which(base::is.na(colData))- |
-
| 109 | -- |
- }- |
-
| 110 | -- |
- )))- |
-
| 111 | -8x | -
- timeBad <- base::rbind(timeBad,base::subset(data,subset=base::seq_len(base::nrow(data)) %in% setNa,select='readout_time'))- |
-
| 112 | -- |
- - |
-
| 113 | -- |
- # Combine this file's measured times with the running list- |
-
| 114 | -8x | -
- timeAll <- base::rbind(timeAll,timeXtra)- |
-
| 115 | -- |
- - |
-
| 116 | -- |
- }- |
-
| 117 | -4x | -
- timeBad <- base::data.frame(readout_time=base::unique(timeBad$readout_time),stringsAsFactors = FALSE) # Initialize- |
-
| 118 | -4x | -
- log$debug(base::paste0(base::nrow(timeBad), ' missing or corrupt records found for sensor group.'))- |
-
| 119 | -- |
- - |
-
| 120 | -4x | -
- timeAll$readout_time <- base::sort(timeAll$readout_time)- |
-
| 121 | -- |
- - |
-
| 122 | -- |
- - |
-
| 123 | -4x | -
- return(base::list(timeAll=timeAll,timeBad=timeBad))- |
-
| 124 | -- |
- - |
-
| 125 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Get metadata/properties from groups json file- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read group json file and return a data frame of metadata/properties- |
-
| 9 | -- |
- #' for the group.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param NameFile Filename (including relative or absolute path). Must be json format.- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @return- |
-
| 16 | -- |
- #' #' A data frame with group metadata.- |
-
| 17 | -- |
- #'- |
-
| 18 | -- |
- #' @references- |
-
| 19 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @keywords currently none- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @examples- |
-
| 24 | -- |
- #' # Not run- |
-
| 25 | -- |
- #' # NameFile <- "/scratch/pfs/group_loader/pressure-air/rel-humidity_HARV000060.json"- |
-
| 26 | -- |
- #' # grpMeta <- NEONprocIS.base::def.grp.meta(NameFile=NameFile)- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @seealso None- |
-
| 29 | -- |
- #'- |
-
| 30 | -- |
- #' @export- |
-
| 31 | -- | - - | -
| 32 | -- |
- # changelog and author contributions / copyrights- |
-
| 33 | -- |
- # Cove Sturtevant (2022-11-20)- |
-
| 34 | -- |
- # original creation- |
-
| 35 | -- | - - | -
| 36 | -- |
- ##############################################################################################- |
-
| 37 | -- |
- def.grp.meta <- function(NameFile,log=NULL){
- |
-
| 38 | -- | - - | -
| 39 | -- |
- # Initialize log if not input- |
-
| 40 | -4x | -
- if (is.null(log)) {
- |
-
| 41 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 42 | -- |
- }- |
-
| 43 | -- |
- - |
-
| 44 | -- |
- # Initialize output- |
-
| 45 | -4x | -
- dmmyChar <- base::character(0)- |
-
| 46 | -4x | -
- dmmyPosx <- base::as.POSIXct(dmmyChar)- |
-
| 47 | -4x | -
- dmmyNumc <- base::numeric(0)- |
-
| 48 | -4x | -
- rpt <- base::data.frame(name=dmmyChar,- |
-
| 49 | -4x | -
- active_periods=dmmyChar,- |
-
| 50 | -4x | -
- group=dmmyChar,- |
-
| 51 | -4x | -
- HOR=dmmyChar,- |
-
| 52 | -4x | -
- VER=dmmyChar,- |
-
| 53 | -4x | -
- data_product_ID=dmmyChar,- |
-
| 54 | -4x | -
- site=dmmyChar,- |
-
| 55 | -4x | -
- domain=dmmyChar,- |
-
| 56 | -4x | -
- visibility_code=dmmyChar,- |
-
| 57 | -4x | -
- stringsAsFactors = FALSE)- |
-
| 58 | -- |
- - |
-
| 59 | -- |
- # First, validate the syntax of input json to see if it is valid.- |
-
| 60 | -4x | -
- validateJson <-- |
-
| 61 | -4x | -
- NEONprocIS.base::def.validate.json (NameFile)- |
-
| 62 | -- |
- - |
-
| 63 | -- |
- # Second, validate the json against the schema only if the syntax is valid.- |
-
| 64 | -- |
- # Otherwise, validateJsonSchema errors out due to the syntax error- |
-
| 65 | -- |
- #- |
-
| 66 | -- | - - | -
| 67 | -4x | -
- validateJsonSchema <- TRUE- |
-
| 68 | -4x | -
- if (validateJson == TRUE) {
- |
-
| 69 | -4x | -
- grpJsonSchema <- system.file("extdata", "group-member-schema.json", package="NEONprocIS.base")
- |
-
| 70 | -4x | -
- log$debug('Checking groups file against expected schema.')
- |
-
| 71 | -4x | -
- validateJsonSchema <-- |
-
| 72 | -4x | -
- NEONprocIS.base::def.validate.json.schema (NameFile, grpJsonSchema)- |
-
| 73 | -- |
- }- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- - |
-
| 76 | -- |
- #if the validation fails, stop- |
-
| 77 | -4x | -
- if ((validateJson == FALSE) || (validateJsonSchema == FALSE))- |
-
| 78 | -- |
- {
- |
-
| 79 | -1x | -
- log$error(- |
-
| 80 | -1x | -
- base::paste0(- |
-
| 81 | -1x | -
- 'In def.grp.meta::: Erred out due to the json validation failure of this file, ',- |
-
| 82 | -1x | -
- NameFile- |
-
| 83 | -- |
- )- |
-
| 84 | -- |
- )- |
-
| 85 | -1x | -
- stop("In def.grp.meta::::: Erred out due to the validation failure of the input JSON")
- |
-
| 86 | -- |
- }- |
-
| 87 | -- |
- - |
-
| 88 | -- |
- - |
-
| 89 | -- |
- # Load the full json into list- |
-
| 90 | -3x | -
- grpFull <- rjson::fromJSON(file=NameFile,simplify=TRUE)- |
-
| 91 | -- | - - | -
| 92 | -- |
- # Pull out additional properties not in the properties list but one level higher- |
-
| 93 | -3x | -
- grpProp <- geojsonsf::geojson_sf(NameFile)- |
-
| 94 | -- |
- - |
-
| 95 | -- |
- # Expected property names that might not be there- |
-
| 96 | -3x | -
- nameProp <- c('name',
- |
-
| 97 | -3x | -
- 'group',- |
-
| 98 | -3x | -
- 'active_periods',- |
-
| 99 | -3x | -
- 'HOR',- |
-
| 100 | -3x | -
- 'VER',- |
-
| 101 | -3x | -
- 'data_product_ID',- |
-
| 102 | -3x | -
- 'site',- |
-
| 103 | -3x | -
- 'domain',- |
-
| 104 | -3x | -
- 'visibility_code')- |
-
| 105 | -- |
- - |
-
| 106 | -- |
- # Populate the output data frame- |
-
| 107 | -3x | -
- for(idxGrp in base::seq_len(base::nrow(grpProp))){
- |
-
| 108 | -- |
- - |
-
| 109 | -- |
- # Ensure property names available. Fill with NA otherwise.- |
-
| 110 | -9x | -
- prop <- base::lapply(nameProp,FUN=function(idxNameProp){
- |
-
| 111 | -81x | -
- if(base::is.null(grpProp[idxGrp,idxNameProp])){
- |
-
| 112 | -46x | -
- return(NA)- |
-
| 113 | -- |
- } else {
- |
-
| 114 | -35x | -
- return(grpProp[idxGrp,idxNameProp])- |
-
| 115 | -- |
- }- |
-
| 116 | -- |
- })- |
-
| 117 | -9x | -
- base::names(prop) <- nameProp- |
-
| 118 | -- |
- - |
-
| 119 | -- |
- # Parse any active dates- |
-
| 120 | -9x | -
- if(!base::is.na(prop$active_periods)){
- |
-
| 121 | -- | - - | -
| 122 | -9x | -
- timeActvList <- rjson::fromJSON(json_str=prop$active_periods)- |
-
| 123 | -- |
- - |
-
| 124 | -- |
- # Turn NULL to NA- |
-
| 125 | -9x | -
- timeActvList <- lapply(timeActvList,FUN=function(timeActvIdx){
- |
-
| 126 | -14x | -
- if(base::is.null(timeActvIdx$start_date)){
- |
-
| 127 | -4x | -
- timeActvIdx$start_date <- NA- |
-
| 128 | -- |
- }- |
-
| 129 | -14x | -
- if(base::is.null(timeActvIdx$end_date)){
- |
-
| 130 | -4x | -
- timeActvIdx$end_date <- NA- |
-
| 131 | -- |
- }- |
-
| 132 | -14x | -
- return(timeActvIdx)- |
-
| 133 | -- |
- }- |
-
| 134 | -- |
- )- |
-
| 135 | -- |
- - |
-
| 136 | -9x | -
- timeActvChar <- base::unlist(timeActvList)- |
-
| 137 | -9x | -
- typeTime <- base::names(timeActvChar)- |
-
| 138 | -9x | -
- numBgn <- base::sum(typeTime=='start_date')- |
-
| 139 | -9x | -
- numEnd <- base::sum(typeTime=='end_date')- |
-
| 140 | -9x | -
- dmmyChar <- base::rep(NA,times=base::max(numBgn,numEnd))- |
-
| 141 | -- |
- - |
-
| 142 | -- |
- # Make a data frame- |
-
| 143 | -9x | -
- timeActv <- base::data.frame(start_date=dmmyChar,end_date=dmmyChar,stringsAsFactors = FALSE)- |
-
| 144 | -9x | -
- timeActv$start_date[base::seq_len(numBgn)] <- timeActvChar[typeTime=='start_date']- |
-
| 145 | -9x | -
- timeActv$end_date[base::seq_len(numEnd)] <- timeActvChar[typeTime=='end_date']- |
-
| 146 | -- |
- - |
-
| 147 | -- |
- # Convert to POSIX- |
-
| 148 | -9x | -
- timeActv$start_date <- base::as.POSIXct(timeActv$start_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 149 | -9x | -
- timeActv$end_date <- base::as.POSIXct(timeActv$end_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 150 | -- |
- - |
-
| 151 | -- |
- # put in a list so we can embed it in the data frame- |
-
| 152 | -9x | -
- timeActv <- base::list(timeActv)- |
-
| 153 | -- |
- - |
-
| 154 | -- |
- } else {
- |
-
| 155 | -! | -
- timeActv <- NA- |
-
| 156 | -- |
- }- |
-
| 157 | -- |
- - |
-
| 158 | -- |
- # Parse any data products- |
-
| 159 | -9x | -
- if(!base::is.na(prop$data_product_ID)){
- |
-
| 160 | -2x | -
- dp <- rjson::fromJSON(json_str=prop$data_product_ID)- |
-
| 161 | -- |
- - |
-
| 162 | -2x | -
- if(base::length(dp) == 0){
- |
-
| 163 | -! | -
- dp <- NA- |
-
| 164 | -- |
- } else {
- |
-
| 165 | -2x | -
- dp <- base::paste0(dp,collapse='|')- |
-
| 166 | -- |
- }- |
-
| 167 | -- |
- } else {
- |
-
| 168 | -7x | -
- dp <- NA- |
-
| 169 | -- |
- }- |
-
| 170 | -- |
- - |
-
| 171 | -- |
- # HOR, VER, site, domain, and visibility_code are higher-level properties. Grab them.- |
-
| 172 | -9x | -
- propMore <- grpFull$features[[idxGrp]]- |
-
| 173 | -9x | -
- if(!base::is.null(propMore$HOR)){
- |
-
| 174 | -4x | -
- prop$HOR <- propMore$HOR- |
-
| 175 | -- |
- }- |
-
| 176 | -9x | -
- if(!base::is.null(propMore$VER)){
- |
-
| 177 | -4x | -
- prop$VER <- propMore$VER- |
-
| 178 | -- |
- }- |
-
| 179 | -9x | -
- if(!base::is.null(propMore$site)){
- |
-
| 180 | -2x | -
- prop$site <- propMore$site- |
-
| 181 | -- |
- }- |
-
| 182 | -9x | -
- if(!base::is.null(propMore$domain)){
- |
-
| 183 | -2x | -
- prop$domain <- propMore$domain- |
-
| 184 | -- |
- }- |
-
| 185 | -9x | -
- if(!base::is.null(propMore$visibility_code)){
- |
-
| 186 | -2x | -
- prop$visibility_code <- propMore$visibility_code- |
-
| 187 | -- |
- }- |
-
| 188 | -- |
- - |
-
| 189 | -- |
- # Consolidate the output- |
-
| 190 | -9x | -
- rptIdx <- base::data.frame(member=prop$name,- |
-
| 191 | -9x | -
- group=prop$group,- |
-
| 192 | -9x | -
- active_periods=NA,- |
-
| 193 | -9x | -
- HOR=prop$HOR,- |
-
| 194 | -9x | -
- VER=prop$VER,- |
-
| 195 | -9x | -
- data_product_ID=dp,- |
-
| 196 | -9x | -
- site=prop$site,- |
-
| 197 | -9x | -
- domain=prop$domain,- |
-
| 198 | -9x | -
- visibility_code=prop$visibility_code,- |
-
| 199 | -9x | -
- stringsAsFactors = FALSE)- |
-
| 200 | -9x | -
- rptIdx$active_periods <- timeActv # Add in the (potential) data frame of active periods.- |
-
| 201 | -- | - - | -
| 202 | -9x | -
- rpt <- base::rbind(rpt,rptIdx)- |
-
| 203 | -- |
- }- |
-
| 204 | -- |
- - |
-
| 205 | -3x | -
- return(rpt)- |
-
| 206 | -- |
- - |
-
| 207 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Get geolocation history from a sensor-based location file- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read sensor locations json file and return the geolocation history of- |
-
| 9 | -- |
- #' all the configured locations within the file.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param NameFile Filename (including relative or absolute path). Must be json format.- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @return- |
-
| 16 | -- |
- #' A list of configured locations found in the file. Nested within the list element for each- |
-
| 17 | -- |
- #' configured location is a list of geolocation history, one list element per location change.- |
-
| 18 | -- |
- #' Further nested within the list element for each geolocation is a variable list of properties- |
-
| 19 | -- |
- #' of that geolocation. Each geolocation property may also be a list of elements.- |
-
| 20 | -- |
- #'- |
-
| 21 | -- |
- #' @references- |
-
| 22 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @keywords currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @examples- |
-
| 27 | -- |
- #' # Not run- |
-
| 28 | -- |
- #' # NameFile <- '~/pfs/aquatroll200_23614_locations.json'- |
-
| 29 | -- |
- #' # locGeoHist <- NEONprocIS.base::def.loc.meta(NameFile=NameFile)- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @seealso \link[NEONprocIS.base]{def.loc.meta}
- |
-
| 32 | -- |
- #' @seealso \link[NEONprocIS.base]{def.loc.filt}
- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @export- |
-
| 35 | -- | - - | -
| 36 | -- |
- # changelog and author contributions / copyrights- |
-
| 37 | -- |
- # Cove Sturtevant (2021-01-26)- |
-
| 38 | -- |
- # original creation- |
-
| 39 | -- |
- # Cove Sturtevant (2023-09-14)- |
-
| 40 | -- |
- # bug fix - location date-times were previously truncated to the day- |
-
| 41 | -- |
- ##############################################################################################- |
-
| 42 | -- |
- def.loc.geo.hist <- function(NameFile,log=NULL){
- |
-
| 43 | -- | - - | -
| 44 | -- |
- # Initialize log if not input- |
-
| 45 | -6x | -
- if (is.null(log)) {
- |
-
| 46 | -6x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 47 | -- |
- }- |
-
| 48 | -- |
- - |
-
| 49 | -- |
- # Validate the json- |
-
| 50 | -6x | -
- if(NEONprocIS.base::def.validate.json(jsonIn=NameFile,log=log) != TRUE){
- |
-
| 51 | -! | -
- stop()- |
-
| 52 | -- |
- }- |
-
| 53 | -- |
- - |
-
| 54 | -- |
- # Load the full json into list & grab metadata- |
-
| 55 | -6x | -
- locFull <- rjson::fromJSON(file=NameFile,simplify=TRUE)- |
-
| 56 | -6x | -
- locMeta <- NEONprocIS.base::def.loc.meta(NameFile=NameFile)- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # For each location, grab the geolocation history- |
-
| 59 | -5x | -
- nameLoc <- base::unique(locMeta$name)- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # Grab geo location history for each named location- |
-
| 62 | -5x | -
- locGeoHist <- base::vector(mode='list',length=base::length(nameLoc)) # Initialize- |
-
| 63 | -5x | -
- base::names(locGeoHist) <- nameLoc- |
-
| 64 | -- |
- - |
-
| 65 | -5x | -
- log$debug(base::paste0(base::length(nameLoc),' configured locations found in file ',NameFile))- |
-
| 66 | -- |
- - |
-
| 67 | -5x | -
- for(nameLocIdx in nameLoc){
- |
-
| 68 | -- |
- - |
-
| 69 | -- |
- # Which index into features- |
-
| 70 | -5x | -
- idxFeat <- base::which(locMeta$name == nameLocIdx)[1]- |
-
| 71 | -- | - - | -
| 72 | -5x | -
- locHist <- locFull$features[[idxFeat]]$properties$locations$features- |
-
| 73 | -5x | -
- numHist <- base::length(locHist) # length of geoloc history- |
-
| 74 | -5x | -
- locGeoHist[[nameLocIdx]] <- base::vector(mode='list',length=numHist) # Initialize- |
-
| 75 | -- |
- - |
-
| 76 | -5x | -
- log$debug(base::paste0(numHist,' geolocations found in the history for configured location ',nameLocIdx))- |
-
| 77 | -- |
- - |
-
| 78 | -5x | -
- for(idxHist in base::seq.int(numHist)){
- |
-
| 79 | -- |
- - |
-
| 80 | -- |
- # Organize location properties- |
-
| 81 | -5x | -
- locHistIdx <- locHist[[idxHist]]- |
-
| 82 | -5x | -
- propLoc <- locHistIdx$properties$location_properties- |
-
| 83 | -5x | -
- propLoc <- base::lapply(propLoc,FUN=function(idx){
- |
-
| 84 | -9x | -
- if(base::is.list(idx)){
- |
-
| 85 | -! | -
- return(base::list(name=idx[[1]],value=idx[[2]]))- |
-
| 86 | -- |
- } else {
- |
-
| 87 | -9x | -
- return(base::list(name=idx[1],value=utils::tail(idx,-1)))- |
-
| 88 | -- |
- }- |
-
| 89 | -- |
- })- |
-
| 90 | -5x | -
- nameProp <- base::unlist(base::lapply(propLoc,FUN=function(idx){idx$name}))
- |
-
| 91 | -5x | -
- propLoc <- base::lapply(propLoc,FUN=function(idx){idx$value})
- |
-
| 92 | -5x | -
- base::names(propLoc) <- nameProp- |
-
| 93 | -- | - - | -
| 94 | -- |
- # Format the dates- |
-
| 95 | -5x | -
- if(base::is.null(locHistIdx$properties$start_date)){
- |
-
| 96 | -! | -
- timeBgnIdx <- NA- |
-
| 97 | -- |
- } else {
- |
-
| 98 | -5x | -
- timeBgnIdx <- base::as.POSIXct(locHistIdx$properties$start_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 99 | -- |
- }- |
-
| 100 | -5x | -
- if(base::is.null(locHistIdx$properties$end_date)){
- |
-
| 101 | -4x | -
- timeEndIdx <- NA- |
-
| 102 | -- |
- } else {
- |
-
| 103 | -1x | -
- timeEndIdx <- base::as.POSIXct(locHistIdx$properties$end_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 104 | -- |
- }- |
-
| 105 | -- |
- - |
-
| 106 | -- |
- # Combine with other location properties in a different list- |
-
| 107 | -5x | -
- propLoc <-- |
-
| 108 | -5x | -
- c(- |
-
| 109 | -5x | -
- base::list(- |
-
| 110 | -5x | -
- start_date=timeBgnIdx,- |
-
| 111 | -5x | -
- end_date=timeEndIdx,- |
-
| 112 | -5x | -
- geometry=locHistIdx$geometry,- |
-
| 113 | -5x | -
- alpha = locHistIdx$properties$alpha,- |
-
| 114 | -5x | -
- beta = locHistIdx$properties$beta,- |
-
| 115 | -5x | -
- gamma = locHistIdx$properties$gamma,- |
-
| 116 | -5x | -
- x_offset = locHistIdx$properties$x_offset,- |
-
| 117 | -5x | -
- y_offset = locHistIdx$properties$y_offset,- |
-
| 118 | -5x | -
- z_offset = locHistIdx$properties$z_offset- |
-
| 119 | -- |
- ),- |
-
| 120 | -5x | -
- propLoc- |
-
| 121 | -- |
- )- |
-
| 122 | -- |
- - |
-
| 123 | -- |
- # Follow the chain of reference locations to the end, nesting their location history- |
-
| 124 | -5x | -
- locRef00 <- locHistIdx$properties$reference_location- |
-
| 125 | -5x | -
- nameLocRef=locRef00$properties$name- |
-
| 126 | -5x | -
- idxRef <- 1- |
-
| 127 | -5x | -
- cont <- TRUE- |
-
| 128 | -- |
- - |
-
| 129 | -5x | -
- while (cont) {
- |
-
| 130 | -- |
- # Get the parent of our current level- |
-
| 131 | -17x | -
- numLvl <- base::length(idxRef)- |
-
| 132 | -- |
- - |
-
| 133 | -17x | -
- if (numLvl == 1) {
- |
-
| 134 | -11x | -
- txtEval <- 'locRef00$properties$locations$features'- |
-
| 135 | -6x | -
- } else if (numLvl == 2) {
- |
-
| 136 | -4x | -
- txtEval <-- |
-
| 137 | -4x | -
- base::paste0(- |
-
| 138 | -4x | -
- 'locRef00$properties$locations$features[[',- |
-
| 139 | -4x | -
- idxRef[1],- |
-
| 140 | -- |
- ']]',- |
-
| 141 | -4x | -
- base::paste0(- |
-
| 142 | -4x | -
- '$properties$reference_location$properties$locations$features',- |
-
| 143 | -4x | -
- collapse = ''- |
-
| 144 | -- |
- )- |
-
| 145 | -- |
- )- |
-
| 146 | -- |
- } else {
- |
-
| 147 | -2x | -
- txtEval <-- |
-
| 148 | -2x | -
- base::paste0(- |
-
| 149 | -2x | -
- 'locRef00$properties$locations$features[[',- |
-
| 150 | -2x | -
- idxRef[1],- |
-
| 151 | -- |
- ']]',- |
-
| 152 | -2x | -
- base::paste0(- |
-
| 153 | -2x | -
- '$properties$reference_location$properties$locations$features[[',- |
-
| 154 | -2x | -
- idxRef[2:(length(idxRef) - 1)],- |
-
| 155 | -- |
- ']]',- |
-
| 156 | -2x | -
- collapse = ''- |
-
| 157 | -- |
- ),- |
-
| 158 | -2x | -
- '$properties$reference_location$properties$locations$features'- |
-
| 159 | -- |
- )- |
-
| 160 | -- |
- }- |
-
| 161 | -17x | -
- locRefPrnt <- base::eval(parse(text = txtEval))- |
-
| 162 | -- |
- - |
-
| 163 | -- |
- # How many geolocs do we have ?- |
-
| 164 | -17x | -
- numRef <- base::length(locRefPrnt)- |
-
| 165 | -- |
- - |
-
| 166 | -- |
- # If there was a named location listed as the first reference location, but no actual geolocation history...- |
-
| 167 | -- |
- # record the name of the reference location- |
-
| 168 | -17x | -
- if(base::length(idxRef) == 1 & numRef == 0 && base::length(- |
-
| 169 | -17x | -
- locRef00$properties$name- |
-
| 170 | -17x | -
- ) != 0) {
- |
-
| 171 | -! | -
- propLoc <- c(propLoc,- |
-
| 172 | -! | -
- base::list(reference_location=- |
-
| 173 | -! | -
- base::list(- |
-
| 174 | -! | -
- base::list(- |
-
| 175 | -! | -
- name=locRef00$properties$name- |
-
| 176 | -- |
- )- |
-
| 177 | -- |
- )- |
-
| 178 | -- |
- )- |
-
| 179 | -- |
- )- |
-
| 180 | -- |
- }- |
-
| 181 | -- |
- - |
-
| 182 | -- |
- - |
-
| 183 | -- |
- # Check whether we are beyond the end of reference geolocations at this level- |
-
| 184 | -17x | -
- if (utils::tail(idxRef, 1) > numRef) {
- |
-
| 185 | -- |
- # Back out a level, increment the index- |
-
| 186 | -8x | -
- idxRef <- idxRef[-length(idxRef)]- |
-
| 187 | -8x | -
- if (base::length(idxRef) == 0) {
- |
-
| 188 | -- |
- # We've gone through the entire hierarchy. We're done.- |
-
| 189 | -5x | -
- cont <- FALSE- |
-
| 190 | -5x | -
- next- |
-
| 191 | -- |
- } else {
- |
-
| 192 | -3x | -
- idxRef[base::length(idxRef)] <-- |
-
| 193 | -3x | -
- utils::tail(idxRef, 1) + 1 # increment index- |
-
| 194 | -3x | -
- next- |
-
| 195 | -- |
- }- |
-
| 196 | -- |
- }- |
-
| 197 | -- |
- - |
-
| 198 | -- |
- # Set locRef to the data at our current level- |
-
| 199 | -9x | -
- if (base::length(idxRef) > 1) {
- |
-
| 200 | -- |
- # Where we will find the reference location info- |
-
| 201 | -3x | -
- txtEval <-- |
-
| 202 | -3x | -
- base::paste0(- |
-
| 203 | -3x | -
- 'locRef00$properties$locations$features[[',- |
-
| 204 | -3x | -
- idxRef[1],- |
-
| 205 | -- |
- ']]',- |
-
| 206 | -3x | -
- base::paste0(- |
-
| 207 | -3x | -
- '$properties$reference_location$properties$locations$features[[',- |
-
| 208 | -3x | -
- idxRef[-1],- |
-
| 209 | -- |
- ']]',- |
-
| 210 | -3x | -
- collapse = ''- |
-
| 211 | -- |
- )- |
-
| 212 | -- |
- )- |
-
| 213 | -- |
- - |
-
| 214 | -- |
- # Where we will find the reference location name- |
-
| 215 | -3x | -
- txtChop <- base::paste0(- |
-
| 216 | -3x | -
- 'locations$features[[',- |
-
| 217 | -3x | -
- tail(idxRef,1),- |
-
| 218 | -- |
- ']]'- |
-
| 219 | -- |
- )- |
-
| 220 | -3x | -
- txtEvalName <-base::paste0(- |
-
| 221 | -3x | -
- base::substr(txtEval,start=1,stop=nchar(txtEval)-base::nchar(txtChop)),- |
-
| 222 | -3x | -
- 'name')- |
-
| 223 | -- |
- - |
-
| 224 | -- |
- # Where we will save the reference location info in the output- |
-
| 225 | -3x | -
- txtAsgnLeft <-- |
-
| 226 | -3x | -
- base::paste0(- |
-
| 227 | -3x | -
- 'propLoc$reference_location[[',- |
-
| 228 | -3x | -
- idxRef[1],- |
-
| 229 | -- |
- ']]',- |
-
| 230 | -3x | -
- base::paste0(- |
-
| 231 | -3x | -
- '$reference_location[[',- |
-
| 232 | -3x | -
- idxRef[-1],- |
-
| 233 | -- |
- ']]',- |
-
| 234 | -3x | -
- collapse = ''- |
-
| 235 | -- |
- )- |
-
| 236 | -- |
- )- |
-
| 237 | -- |
- } else {
- |
-
| 238 | -- |
- # Where we will find the reference location geolocation history- |
-
| 239 | -6x | -
- txtEval <-- |
-
| 240 | -6x | -
- base::paste0('locRef00$properties$locations$features[[',
- |
-
| 241 | -6x | -
- idxRef[1],- |
-
| 242 | -- |
- ']]')- |
-
| 243 | -- |
- - |
-
| 244 | -- |
- # Where we will find the reference location name- |
-
| 245 | -6x | -
- txtChop <- base::paste0(- |
-
| 246 | -6x | -
- 'locations$features[[',- |
-
| 247 | -6x | -
- tail(idxRef,1),- |
-
| 248 | -- |
- ']]'- |
-
| 249 | -- |
- )- |
-
| 250 | -6x | -
- txtEvalName <-base::paste0(- |
-
| 251 | -6x | -
- base::substr(txtEval,start=1,stop=nchar(txtEval)-base::nchar(txtChop)),- |
-
| 252 | -6x | -
- 'name')- |
-
| 253 | -- |
- - |
-
| 254 | -- |
- # Where we will save the reference location info in the output- |
-
| 255 | -6x | -
- txtAsgnLeft <-- |
-
| 256 | -6x | -
- base::paste0('propLoc$reference_location[[',
- |
-
| 257 | -6x | -
- idxRef[1],- |
-
| 258 | -- |
- ']]')- |
-
| 259 | -- |
- }- |
-
| 260 | -9x | -
- locRef <- base::eval(parse(text = txtEval))- |
-
| 261 | -9x | -
- nameLocRef <- base::eval(parse(text = txtEvalName))- |
-
| 262 | -- |
- - |
-
| 263 | -- |
- # Organize location properties- |
-
| 264 | -9x | -
- propLocRef <- locRef$properties$location_properties- |
-
| 265 | -9x | -
- propLocRef <- base::lapply(propLocRef,FUN=function(idx){
- |
-
| 266 | -11x | -
- if(base::is.list(idx)){
- |
-
| 267 | -2x | -
- return(base::list(name=idx[[1]],value=idx[[2]]))- |
-
| 268 | -- |
- } else {
- |
-
| 269 | -9x | -
- return(base::list(name=idx[1],value=utils::tail(idx,-1)))- |
-
| 270 | -- |
- }- |
-
| 271 | -- |
- })- |
-
| 272 | -11x | -
- nameProp <- base::unlist(base::lapply(propLocRef,FUN=function(idx){idx$name}))
- |
-
| 273 | -11x | -
- propLocRef <- base::lapply(propLocRef,FUN=function(idx){idx$value})
- |
-
| 274 | -9x | -
- base::names(propLocRef) <- nameProp- |
-
| 275 | -- |
- - |
-
| 276 | -- |
- # Format the dates- |
-
| 277 | -9x | -
- if(base::is.null(locRef$properties$start_date)){
- |
-
| 278 | -! | -
- timeBgnRef <- NA- |
-
| 279 | -- |
- } else {
- |
-
| 280 | -9x | -
- timeBgnRef <- base::as.POSIXct(locRef$properties$start_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 281 | -- |
- }- |
-
| 282 | -9x | -
- if(base::is.null(locRef$properties$end_date)){
- |
-
| 283 | -7x | -
- timeEndRef <- NA- |
-
| 284 | -- |
- } else {
- |
-
| 285 | -2x | -
- timeEndRef <- base::as.POSIXct(locRef$properties$end_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 286 | -- |
- }- |
-
| 287 | -- |
- - |
-
| 288 | -- |
- # Combine with other location properties in a different list- |
-
| 289 | -9x | -
- propLocRef <-- |
-
| 290 | -9x | -
- c(- |
-
| 291 | -9x | -
- base::list(- |
-
| 292 | -9x | -
- name=nameLocRef,- |
-
| 293 | -9x | -
- start_date=timeBgnRef,- |
-
| 294 | -9x | -
- end_date=timeEndRef,- |
-
| 295 | -9x | -
- geometry=locRef$geometry,- |
-
| 296 | -9x | -
- alpha = locRef$properties$alpha,- |
-
| 297 | -9x | -
- beta = locRef$properties$beta,- |
-
| 298 | -9x | -
- gamma = locRef$properties$gamma,- |
-
| 299 | -9x | -
- x_offset = locRef$properties$x_offset,- |
-
| 300 | -9x | -
- y_offset = locRef$properties$y_offset,- |
-
| 301 | -9x | -
- z_offset = locRef$properties$z_offset- |
-
| 302 | -- |
- ),- |
-
| 303 | -9x | -
- propLocRef- |
-
| 304 | -- |
- )- |
-
| 305 | -- | - - | -
| 306 | -- |
- # save it into the output- |
-
| 307 | -9x | -
- txtAsgn <- base::paste0(txtAsgnLeft,' <- propLocRef')- |
-
| 308 | -9x | -
- base::eval(base::parse(text = txtAsgn))- |
-
| 309 | -- |
- - |
-
| 310 | -- |
- # Are there more reference locations?- |
-
| 311 | -9x | -
- if (base::length(- |
-
| 312 | -9x | -
- locRef$properties$reference_location$properties$locations$features- |
-
| 313 | -9x | -
- ) != 0) {
- |
-
| 314 | -- |
- # Go a level deeper- |
-
| 315 | -3x | -
- idxRef <- c(idxRef, 1)- |
-
| 316 | -3x | -
- next- |
-
| 317 | -- |
- - |
-
| 318 | -- |
- } else {
- |
-
| 319 | -- |
- # We found the end of the reference chain! Let's move on to the next geolocation at this same level.- |
-
| 320 | -- |
- - |
-
| 321 | -- |
- # If there was a named location listed as the reference location, but no actual geolocation history...- |
-
| 322 | -- |
- # record the name of the reference location- |
-
| 323 | -6x | -
- if(base::length(- |
-
| 324 | -6x | -
- locRef$properties$reference_location$properties$name- |
-
| 325 | -6x | -
- ) != 0) {
- |
-
| 326 | -3x | -
- propLocRef <- c(propLocRef,- |
-
| 327 | -3x | -
- base::list(reference_location=- |
-
| 328 | -3x | -
- base::list(- |
-
| 329 | -3x | -
- base::list(- |
-
| 330 | -3x | -
- name=locRef$properties$reference_location$properties$name- |
-
| 331 | -- |
- )- |
-
| 332 | -- |
- )- |
-
| 333 | -- |
- )- |
-
| 334 | -- |
- )- |
-
| 335 | -- |
- # save it into the output- |
-
| 336 | -3x | -
- txtAsgn <- base::paste0(txtAsgnLeft,' <- propLocRef')- |
-
| 337 | -3x | -
- base::eval(base::parse(text = txtAsgn))- |
-
| 338 | -- |
- - |
-
| 339 | -- |
- }- |
-
| 340 | -- |
- - |
-
| 341 | -- |
- - |
-
| 342 | -6x | -
- idxRef[base::length(idxRef)] <-- |
-
| 343 | -6x | -
- utils::tail(idxRef, 1) + 1- |
-
| 344 | -- |
- - |
-
| 345 | -- |
- }- |
-
| 346 | -5x | -
- } # End loop around reference locations- |
-
| 347 | -- |
- - |
-
| 348 | -- |
- # Save the location properties for this geolocation history entry- |
-
| 349 | -5x | -
- locGeoHist[[nameLocIdx]][[idxHist]] <- propLoc- |
-
| 350 | -- |
- - |
-
| 351 | -- |
- } # End loop around location history- |
-
| 352 | -- |
- - |
-
| 353 | -- |
- } # End loop around named locations- |
-
| 354 | -- | - - | -
| 355 | -5x | -
- return(locGeoHist)- |
-
| 356 | -- |
- - |
-
| 357 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Determine missing time periods- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Given overall beginning and ending times and a data frame of time ranges,- |
-
| 9 | -- |
- #' determine the time periods that are missing.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param TimeBgn A POSIXct timestamp of the start date of interest (inclusive)- |
-
| 12 | -- |
- #' @param TimeEnd A POSIXct timestamp of the end date of interest (exclusive)- |
-
| 13 | -- |
- #' @param timeFull A data frame of time ranges considered covered, with columns: \cr- |
-
| 14 | -- |
- #' \code{timeBgn} POSIXct timestamps of the start date of the time range (inclusive)\cr
- |
-
| 15 | -- |
- #' \code{timeEnd} POSIXct timestamps of the end date of the time range (exclusive)\cr
- |
-
| 16 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 17 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @return A data frame of missing time ranges:\cr- |
-
| 20 | -- |
- #' \code{timeBgn} POSIXct. The start date-time (inclusive) of the missing time range \cr
- |
-
| 21 | -- |
- #' \code{timeEnd} POSIXct. The end date-time (exclusive) of the missing time range \cr
- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @references- |
-
| 24 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @keywords currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @examples- |
-
| 29 | -- |
- #' TimeBgn <- base::as.POSIXct('2019-01-01',tz='GMT')
- |
-
| 30 | -- |
- #' TimeEnd <- base::as.POSIXct('2019-01-10',tz='GMT')
- |
-
| 31 | -- |
- #' timeFull <- base::data.frame(timeBgn=as.POSIXct(c('2019-01-02','2019-01-05'),tz='GMT'),
- |
-
| 32 | -- |
- #' timeEnd=as.POSIXct(c('2019-01-03','2019-01-07'),tz='GMT'))
- |
-
| 33 | -- |
- #' # NEONprocIS.base::def.time.miss(TimeBgn=TimeBgn,TimeEnd=TimeEnd,timeFull=timeFull)- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @seealso None currently- |
-
| 36 | -- |
- #'- |
-
| 37 | -- |
- #' @export- |
-
| 38 | -- | - - | -
| 39 | -- |
- # changelog and author contributions / copyrights- |
-
| 40 | -- |
- # Cove Sturtevant (2020-02-06)- |
-
| 41 | -- |
- # original creation- |
-
| 42 | -- |
- # Cove Sturtevant (2020-06-10)- |
-
| 43 | -- |
- # bug fix when entry in timeFull is completely outside the range of TimeBgn and TimeEnd- |
-
| 44 | -- |
- # Cove Sturtevant (2022-08-10)- |
-
| 45 | -- |
- # enabled input of overlapping time ranges in timeFull- |
-
| 46 | -- |
- ##############################################################################################- |
-
| 47 | -- |
- def.time.miss <- function(TimeBgn, TimeEnd, timeFull, log = NULL) {
- |
-
| 48 | -- |
- # Initialize log if not input- |
-
| 49 | -5x | -
- if (is.null(log)) {
- |
-
| 50 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 51 | -- |
- }- |
-
| 52 | -- |
- - |
-
| 53 | -- |
- # Sort the covered time ranges- |
-
| 54 | -5x | -
- timeFull <-- |
-
| 55 | -5x | -
- timeFull[base::order(timeFull$timeBgn, decreasing = FALSE), ]- |
-
| 56 | -- |
- - |
-
| 57 | -- |
- # Get rid of any ranges beginning and ending outside our range of interest- |
-
| 58 | -5x | -
- setKeep <- !(timeFull$timeBgn >= TimeEnd | timeFull$timeEnd <= TimeBgn)- |
-
| 59 | -5x | -
- timeFull <- base::subset(timeFull,subset=setKeep)- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # Truncate ranges that overlap. Note: this works only if timeFull is sorted above with increasing timeBgn (so keep it that way!)- |
-
| 62 | -5x | -
- for(idxRow in base::rev(base::seq_len(base::nrow(timeFull)))){
- |
-
| 63 | -- |
- - |
-
| 64 | -6x | -
- timeFull$timeBgn[idxRow] <- base::max(timeFull$timeBgn[idxRow],timeFull$timeEnd[seq_len(idxRow-1)])- |
-
| 65 | -- |
- - |
-
| 66 | -- |
- # If we truncated the whole time range, remove it.- |
-
| 67 | -6x | -
- if(timeFull$timeEnd[idxRow]-timeFull$timeBgn[idxRow] <= as.difftime(0,units='secs')){
- |
-
| 68 | -! | -
- timeFull <- timeFull[-idxRow,]- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Initialize- |
-
| 73 | -5x | -
- dmmyTime <-- |
-
| 74 | -5x | -
- base::as.POSIXct(x = numeric(0), origin = as.POSIXct('1970-01-01', tz = 'GMT'))
- |
-
| 75 | -5x | -
- base::attr(dmmyTime, 'tzone') <- base::attr(TimeBgn, 'tzone')- |
-
| 76 | -5x | -
- timeMiss <-- |
-
| 77 | -5x | -
- base::data.frame(timeBgn = dmmyTime,- |
-
| 78 | -5x | -
- timeEnd = dmmyTime,- |
-
| 79 | -5x | -
- stringsAsFactors = FALSE)- |
-
| 80 | -- |
- - |
-
| 81 | -- |
- # Look for the entire time period being missing- |
-
| 82 | -5x | -
- if (base::nrow(timeFull) == 0) {
- |
-
| 83 | -2x | -
- timeMiss <-- |
-
| 84 | -2x | -
- base::data.frame(- |
-
| 85 | -2x | -
- timeBgn = TimeBgn,- |
-
| 86 | -2x | -
- timeEnd = TimeEnd,- |
-
| 87 | -2x | -
- stringsAsFactors = FALSE- |
-
| 88 | -- |
- )- |
-
| 89 | -2x | -
- return(timeMiss)- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- # Look for gap at beginning- |
-
| 93 | -3x | -
- if (TimeBgn < timeFull$timeBgn[1]) {
- |
-
| 94 | -1x | -
- timeMiss <-- |
-
| 95 | -1x | -
- base::rbind(- |
-
| 96 | -1x | -
- timeMiss,- |
-
| 97 | -1x | -
- base::data.frame(- |
-
| 98 | -1x | -
- timeBgn = TimeBgn,- |
-
| 99 | -1x | -
- timeEnd = timeFull$timeBgn[1],- |
-
| 100 | -1x | -
- stringsAsFactors = FALSE- |
-
| 101 | -- |
- )- |
-
| 102 | -- |
- )- |
-
| 103 | -- |
- }- |
-
| 104 | -- |
- # Look for gap at End- |
-
| 105 | -3x | -
- if (TimeEnd > utils::tail(timeFull$timeEnd, n = 1)) {
- |
-
| 106 | -2x | -
- timeMiss <-- |
-
| 107 | -2x | -
- base::rbind(- |
-
| 108 | -2x | -
- timeMiss,- |
-
| 109 | -2x | -
- base::data.frame(- |
-
| 110 | -2x | -
- timeBgn = utils::tail(timeFull$timeEnd, n = 1),- |
-
| 111 | -2x | -
- timeEnd = TimeEnd,- |
-
| 112 | -2x | -
- stringsAsFactors = FALSE- |
-
| 113 | -- |
- )- |
-
| 114 | -- |
- )- |
-
| 115 | -- |
- }- |
-
| 116 | -- |
- - |
-
| 117 | -- |
- # Look for gaps between rows- |
-
| 118 | -3x | -
- if (base::nrow(timeFull) > 1) {
- |
-
| 119 | -3x | -
- for (idxRowFull in 2:nrow(timeFull)) {
- |
-
| 120 | -3x | -
- if (timeFull$timeBgn[idxRowFull] > timeFull$timeEnd[idxRowFull - 1]) {
- |
-
| 121 | -1x | -
- timeMiss <-- |
-
| 122 | -1x | -
- base::rbind(- |
-
| 123 | -1x | -
- timeMiss,- |
-
| 124 | -1x | -
- base::data.frame(- |
-
| 125 | -1x | -
- timeBgn = timeFull$timeEnd[idxRowFull - 1],- |
-
| 126 | -1x | -
- timeEnd = timeFull$timeBgn[idxRowFull],- |
-
| 127 | -1x | -
- stringsAsFactors = FALSE- |
-
| 128 | -- |
- )- |
-
| 129 | -- |
- )- |
-
| 130 | -- |
- }- |
-
| 131 | -- |
- }- |
-
| 132 | -- |
- }- |
-
| 133 | -- |
- - |
-
| 134 | -- |
- # Sort the missing periods- |
-
| 135 | -3x | -
- timeMiss <-- |
-
| 136 | -3x | -
- timeMiss[base::order(timeMiss$timeBgn, decreasing = FALSE), ]- |
-
| 137 | -- |
- - |
-
| 138 | -3x | -
- return(timeMiss)- |
-
| 139 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Get metadata/properties from sensor locations json file- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read sensor locations json file and return a data frame of metadata/properties- |
-
| 9 | -- |
- #' filtered for a selected named location and/or install time range of interest. This function also- |
-
| 10 | -- |
- #' reads location-based location files (no sensor install information)- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param NameFile Filename (including relative or absolute path). Must be json format.- |
-
| 13 | -- |
- #' @param NameLoc Character value of the named location to restrict output to. Defaults to NULL,- |
-
| 14 | -- |
- #' in which case no filtering is done for named location- |
-
| 15 | -- |
- #' @param TimeBgn POSIXct timestamp of the start time of interest (inclusive). Defaults to NULL,- |
-
| 16 | -- |
- #' in which case no filtering is done for installed time range. Note that- |
-
| 17 | -- |
- #' no time filtering is performed for location-based location files, since there is no sensor install- |
-
| 18 | -- |
- #' information included, and only one location is included in the location-based location files.- |
-
| 19 | -- |
- #' @param TimeEnd POSIXct timestamp of the end time of interest (non-inclusive). Defaults to NULL, in- |
-
| 20 | -- |
- #' which case the location information will be filtered for the exact time of TimeBgn. Note that- |
-
| 21 | -- |
- #' no time filtering is performed for location-based location files, since there is no sensor install- |
-
| 22 | -- |
- #' information included, and only one location is included in the location-based location files.- |
-
| 23 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 24 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @return- |
-
| 27 | -- |
- #' A data frame with location metadata.- |
-
| 28 | -- |
- #'- |
-
| 29 | -- |
- #' @references- |
-
| 30 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @keywords currently none- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @examples- |
-
| 35 | -- |
- #' # Not run- |
-
| 36 | -- |
- #' # NameFile <- '/scratch/pfs/prt_calibrated_location_group/prt/2019/01/01/767/location/prt_767_locations.json'- |
-
| 37 | -- |
- #' # NameLoc <- 'CFGLOC100140'- |
-
| 38 | -- |
- #' # TimeBgn <- base::as.POSIXct('2019-01-01',tz='GMT)
- |
-
| 39 | -- |
- #' # TimeEnd <- base::as.POSIXct('2019-01-02',tz='GMT)
- |
-
| 40 | -- |
- #' # locMeta <- NEONprocIS.base::def.loc.meta(NameFile=NameFile,NameLoc=NameLoc,TimeBgn=TimeBgn,TimeEnd=TimeEnd)- |
-
| 41 | -- | - - | -
| 42 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.avro.deve}
- |
-
| 43 | -- |
- #'- |
-
| 44 | -- |
- #' @export- |
-
| 45 | -- | - - | -
| 46 | -- |
- # changelog and author contributions / copyrights- |
-
| 47 | -- |
- # Cove Sturtevant (2020-02-19)- |
-
| 48 | -- |
- # original creation- |
-
| 49 | -- |
- # Cove Sturtevant (2020-07-16)- |
-
| 50 | -- |
- # output source_type and source_id from location file- |
-
| 51 | -- |
- # Cove Sturtevant (2021-03-16)- |
-
| 52 | -- |
- # Add parsing of active periods- |
-
| 53 | -- |
- # Cove Sturtevant (2021-08-31)- |
-
| 54 | -- |
- # Add error checking of location file schema- |
-
| 55 | -- |
- # Cove Sturtevant (2021-11-01)- |
-
| 56 | -- |
- # Remove transaction date from output- |
-
| 57 | -- |
- # Add named location group to output- |
-
| 58 | -- |
- # Cove Sturtevant (2022-09-22)- |
-
| 59 | -- |
- # Incorporate IS default processing start date- |
-
| 60 | -- |
- # Accommodate updates to location files that ensure all possible scenarios for active periods- |
-
| 61 | -- |
- # are represented.- |
-
| 62 | -- |
- # Mija Choi (2022-12-16)- |
-
| 63 | -- |
- # Modified to remove grp checking as group is removed from location_loader output- |
-
| 64 | -- |
- ##############################################################################################- |
-
| 65 | -- |
- def.loc.meta <- function(NameFile,- |
-
| 66 | -- |
- NameLoc=NULL,- |
-
| 67 | -- |
- TimeBgn=NULL,- |
-
| 68 | -- |
- TimeEnd=NULL,- |
-
| 69 | -- |
- log=NULL- |
-
| 70 | -- |
- ){
- |
-
| 71 | -- | - - | -
| 72 | -- |
- # Initialize log if not input- |
-
| 73 | -20x | -
- if (is.null(log)) {
- |
-
| 74 | -20x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 75 | -- |
- }- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- # Initialize output- |
-
| 78 | -20x | -
- dmmyChar <- base::character(0)- |
-
| 79 | -20x | -
- dmmyPosx <- base::as.POSIXct(dmmyChar)- |
-
| 80 | -20x | -
- dmmyNumc <- base::numeric(0)- |
-
| 81 | -20x | -
- rpt <- base::data.frame(name=dmmyChar,- |
-
| 82 | -20x | -
- site=dmmyChar,- |
-
| 83 | -20x | -
- install_date=dmmyPosx,- |
-
| 84 | -20x | -
- remove_date=dmmyPosx,- |
-
| 85 | -20x | -
- active_periods=dmmyChar,- |
-
| 86 | -20x | -
- context=dmmyChar,- |
-
| 87 | -20x | -
- location_id=dmmyChar,- |
-
| 88 | -20x | -
- location_code=dmmyChar,- |
-
| 89 | -20x | -
- HOR=dmmyChar,- |
-
| 90 | -20x | -
- VER=dmmyChar,- |
-
| 91 | -20x | -
- dataRate=dmmyNumc,- |
-
| 92 | -20x | -
- stringsAsFactors = FALSE)- |
-
| 93 | -- |
- - |
-
| 94 | -- |
- # There are two types of location files, asset-based and location-based. The schema must match one of these to be valid.- |
-
| 95 | -- |
- # First, validate the syntax of input json to see if it is valid. This checks either type.- |
-
| 96 | -- |
- #- |
-
| 97 | -20x | -
- validateJson <- NEONprocIS.base::def.validate.json (NameFile,log)- |
-
| 98 | -- |
- #- |
-
| 99 | -- |
- # Second, validate the json against the schema only if the syntax is valid.- |
-
| 100 | -- |
- # Otherwise, validateJsonSchema errors out due to the syntax error- |
-
| 101 | -- |
- #- |
-
| 102 | -- |
- - |
-
| 103 | -20x | -
- validateJsonSchema <- FALSE- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- # First try to validate the asset-based file schema- |
-
| 106 | -20x | -
- if (validateJson == TRUE) {
- |
-
| 107 | -20x | -
- locJsonSchema <- system.file("extdata", "locations-sensor-schema.json", package="NEONprocIS.base")
- |
-
| 108 | -20x | -
- log$debug('Checking location file against asset-based file schema.')
- |
-
| 109 | -20x | -
- validateJsonSchema <-- |
-
| 110 | -20x | -
- NEONprocIS.base::def.validate.json.schema (NameFile, locJsonSchema,log)- |
-
| 111 | -- |
- }- |
-
| 112 | -- |
- - |
-
| 113 | -- |
- # Next try to validate the location-based file schema- |
-
| 114 | -20x | -
- if (validateJson == TRUE && validateJsonSchema == FALSE) {
- |
-
| 115 | -4x | -
- locJsonSchema <- system.file("extdata", "locations-namedLocation-schema.json", package="NEONprocIS.base")
- |
-
| 116 | -4x | -
- log$debug('Checking location file against location-based file schema.')
- |
-
| 117 | -4x | -
- validateJsonSchema <-- |
-
| 118 | -4x | -
- NEONprocIS.base::def.validate.json.schema (NameFile, locJsonSchema,log)- |
-
| 119 | -- |
- }- |
-
| 120 | -- |
- - |
-
| 121 | -- |
- #if the validation fails, stop- |
-
| 122 | -20x | -
- if ((validateJson == FALSE) || (validateJsonSchema == FALSE))- |
-
| 123 | -- |
- {
- |
-
| 124 | -2x | -
- log$error(- |
-
| 125 | -2x | -
- base::paste0(- |
-
| 126 | -2x | -
- 'In def.loc.meta::: Erred out due to the json validation failure of this file, ',- |
-
| 127 | -2x | -
- NameFile- |
-
| 128 | -- |
- )- |
-
| 129 | -- |
- )- |
-
| 130 | -2x | -
- stop("In def.loc.meta::::: Erred out due to the validation failure of the input JSON")
- |
-
| 131 | -- |
- }- |
-
| 132 | -- |
- - |
-
| 133 | -- |
- - |
-
| 134 | -- |
- # Load the full json into list- |
-
| 135 | -18x | -
- locFull <- rjson::fromJSON(file=NameFile,simplify=TRUE)- |
-
| 136 | -- |
- - |
-
| 137 | -- |
- # Top level properties of sensor-based location file- |
-
| 138 | -18x | -
- if(!base::is.null(locFull$source_type)){
- |
-
| 139 | -16x | -
- srcType <- locFull$source_type- |
-
| 140 | -- |
- } else {
- |
-
| 141 | -2x | -
- srcType <- NA- |
-
| 142 | -- |
- }- |
-
| 143 | -18x | -
- if(!base::is.null(locFull$source_id)){
- |
-
| 144 | -16x | -
- srcId <- locFull$source_id- |
-
| 145 | -- |
- } else {
- |
-
| 146 | -2x | -
- srcId <- NA- |
-
| 147 | -- |
- }- |
-
| 148 | -- |
- - |
-
| 149 | -- |
- # Properties of each named location listed in the locations file- |
-
| 150 | -- |
- # Lists the named location, site, install_date, remove_date, active periods, etc- |
-
| 151 | -18x | -
- locProp <- geojsonsf::geojson_sf(NameFile) # data frame- |
-
| 152 | -18x | -
- if(!base::is.null(locProp$install_date)){
- |
-
| 153 | -16x | -
- locProp$install_date <- base::as.POSIXct(locProp$install_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 154 | -- |
- } else {
- |
-
| 155 | -2x | -
- locProp$install_date <- NA- |
-
| 156 | -- |
- }- |
-
| 157 | -18x | -
- if(!base::is.null(locProp$remove_date)){
- |
-
| 158 | -16x | -
- locProp$remove_date <- base::as.POSIXct(locProp$remove_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 159 | -- |
- } else {
- |
-
| 160 | -2x | -
- locProp$remove_date <- NA- |
-
| 161 | -- |
- }- |
-
| 162 | -18x | -
- if(!base::is.null(locProp$active_periods)){
- |
-
| 163 | -2x | -
- locProp$active_periods <- locProp$active_periods- |
-
| 164 | -- |
- } else {
- |
-
| 165 | -16x | -
- locProp$active_periods <- NA- |
-
| 166 | -- |
- }- |
-
| 167 | -- |
- - |
-
| 168 | -- |
- # Is there a named location and/or date range we want to restrict location info to?- |
-
| 169 | -18x | -
- setLocProp <- base::seq_len(base::nrow(locProp))- |
-
| 170 | -18x | -
- testTime <- base::any(!base::is.na(locProp$install_date))- |
-
| 171 | -18x | -
- if(!base::is.null(NameLoc)){
- |
-
| 172 | -1x | -
- setLocProp <- base::intersect(setLocProp,base::which(locProp$name == NameLoc))- |
-
| 173 | -- |
- }- |
-
| 174 | -18x | -
- if(testTime && !base::is.null(TimeBgn) && (base::is.null(TimeEnd) || TimeBgn == TimeEnd)){
- |
-
| 175 | -3x | -
- setLocProp <- base::intersect(setLocProp,base::which(locProp$install_date <= TimeBgn & (base::is.na(locProp$remove_date) | locProp$remove_date > TimeBgn)))- |
-
| 176 | -15x | -
- } else if (testTime && !base::is.null(TimeBgn) && !base::is.null(TimeEnd)){
- |
-
| 177 | -1x | -
- setLocProp <- base::intersect(setLocProp,base::which(locProp$install_date <= TimeEnd & (base::is.na(locProp$remove_date) | locProp$remove_date > TimeBgn)))- |
-
| 178 | -- |
- }- |
-
| 179 | -18x | -
- locProp <- locProp[setLocProp,]- |
-
| 180 | -- |
- - |
-
| 181 | -- |
- # Pull out additional properties not in the properties list but one level higher- |
-
| 182 | -18x | -
- locPropMore <- locFull$features[setLocProp]- |
-
| 183 | -- |
- - |
-
| 184 | -- |
- # Expected property names that might not be there- |
-
| 185 | -18x | -
- nameProp <- c('Required Asset Management Location ID',
- |
-
| 186 | -18x | -
- 'Required Asset Management Location Code',- |
-
| 187 | -18x | -
- 'HOR',- |
-
| 188 | -18x | -
- 'VER',- |
-
| 189 | -18x | -
- 'Data Rate',- |
-
| 190 | -18x | -
- 'IS Processing Default Start Date')- |
-
| 191 | -- |
- - |
-
| 192 | -- |
- # Populate the output data frame- |
-
| 193 | -18x | -
- for(idxLoc in base::seq_len(base::nrow(locProp))){
- |
-
| 194 | -- |
- - |
-
| 195 | -- |
- # Ensure property names available. Fill with NA otherwise.- |
-
| 196 | -19x | -
- propFill <- base::lapply(nameProp,FUN=function(idxNameProp){
- |
-
| 197 | -114x | -
- if(base::is.null(locPropMore[[idxLoc]][[idxNameProp]])){
- |
-
| 198 | -23x | -
- return(NA)- |
-
| 199 | -- |
- } else {
- |
-
| 200 | -91x | -
- return(locPropMore[[idxLoc]][[idxNameProp]])- |
-
| 201 | -- |
- }- |
-
| 202 | -- |
- })- |
-
| 203 | -19x | -
- base::names(propFill) <- nameProp- |
-
| 204 | -- |
- - |
-
| 205 | -- |
- # format multiple values for context- |
-
| 206 | -19x | -
- ctxt <- locProp$context[idxLoc]- |
-
| 207 | -19x | -
- if(base::length(ctxt) > 0){
- |
-
| 208 | -19x | -
- ctxt <- base::gsub(pattern='[\\[\\"]',replacement="",x=ctxt)- |
-
| 209 | -19x | -
- ctxt <- base::gsub(pattern='\\]',replacement="",x=ctxt)- |
-
| 210 | -19x | -
- ctxt <- base::strsplit(ctxt,',')[[1]]- |
-
| 211 | -19x | -
- ctxt <- base::paste0(base::unique(ctxt),collapse='|')- |
-
| 212 | -- |
- }- |
-
| 213 | -- |
- - |
-
| 214 | -19x | -
- if(base::length(ctxt) == 0 || base::nchar(ctxt) == 0) {
- |
-
| 215 | -1x | -
- ctxt <- NA- |
-
| 216 | -- |
- }- |
-
| 217 | -- |
- - |
-
| 218 | -- |
- # Parse any active dates and place in a data frame- |
-
| 219 | -19x | -
- if(!base::is.na(locProp$active_periods[idxLoc])){
- |
-
| 220 | -- | - - | -
| 221 | -2x | -
- timeActvList <- rjson::fromJSON(json_str=locProp$active_periods[idxLoc])- |
-
| 222 | -- |
- - |
-
| 223 | -- |
- # Turn NULL to NA- |
-
| 224 | -2x | -
- timeActvList <- base::lapply(timeActvList,FUN=function(timeActvIdx){
- |
-
| 225 | -3x | -
- if(base::is.null(timeActvIdx$start_date)){
- |
-
| 226 | -! | -
- timeActvIdx$start_date <- NA- |
-
| 227 | -- |
- }- |
-
| 228 | -3x | -
- if(base::is.null(timeActvIdx$end_date)){
- |
-
| 229 | -1x | -
- timeActvIdx$end_date <- NA- |
-
| 230 | -- |
- }- |
-
| 231 | -3x | -
- return(timeActvIdx)- |
-
| 232 | -- |
- }- |
-
| 233 | -- |
- )- |
-
| 234 | -- |
- - |
-
| 235 | -2x | -
- numActv <- base::length(timeActvList)- |
-
| 236 | -2x | -
- dmmyChar <- base::rep(NA,times=numActv)- |
-
| 237 | -2x | -
- timeActv <- base::data.frame(start_date=dmmyChar,end_date=dmmyChar,stringsAsFactors = FALSE)- |
-
| 238 | -2x | -
- for(idxActv in base::seq_len(base::length(timeActvList))){
- |
-
| 239 | -3x | -
- if(!base::is.null(timeActvList[[idxActv]]$start_date)){
- |
-
| 240 | -3x | -
- timeActv$start_date[idxActv] <- timeActvList[[idxActv]]$start_date- |
-
| 241 | -- |
- }- |
-
| 242 | -3x | -
- if(!base::is.null(timeActvList[[idxActv]]$end_date)){
- |
-
| 243 | -3x | -
- timeActv$end_date[idxActv] <- timeActvList[[idxActv]]$end_date- |
-
| 244 | -- |
- }- |
-
| 245 | -- |
- }- |
-
| 246 | -- | - - | -
| 247 | -- |
- # Convert to POSIX- |
-
| 248 | -2x | -
- timeActv$start_date <- base::as.POSIXct(timeActv$start_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 249 | -2x | -
- timeActv$end_date <- base::as.POSIXct(timeActv$end_date,format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 250 | -- |
- - |
-
| 251 | -- |
- # put in a list so we can embed it in the data frame- |
-
| 252 | -2x | -
- timeActv <- base::list(timeActv)- |
-
| 253 | -- |
- - |
-
| 254 | -- |
- } else {
- |
-
| 255 | -17x | -
- timeActv <- NA- |
-
| 256 | -- |
- }- |
-
| 257 | -- |
- - |
-
| 258 | -- |
- # Parse IS processing default start date- |
-
| 259 | -19x | -
- if(!base::is.na(propFill[['IS Processing Default Start Date']])){
- |
-
| 260 | -- |
- - |
-
| 261 | -- |
- # Convert to POSIX- |
-
| 262 | -2x | -
- timeProcBgnDflt <- base::as.POSIXct(propFill[['IS Processing Default Start Date']],format='%Y-%m-%dT%H:%M:%SZ',tz='GMT')- |
-
| 263 | -- | - - | -
| 264 | -- |
- } else {
- |
-
| 265 | -17x | -
- timeProcBgnDflt <- NA- |
-
| 266 | -- |
- }- |
-
| 267 | -- |
- - |
-
| 268 | -19x | -
- rptIdx <- base::data.frame(name=locProp$name[idxLoc],- |
-
| 269 | -19x | -
- site=locProp$site[idxLoc],- |
-
| 270 | -19x | -
- source_type=srcType,- |
-
| 271 | -19x | -
- source_id=srcId,- |
-
| 272 | -19x | -
- install_date=locProp$install_date[idxLoc],- |
-
| 273 | -19x | -
- remove_date=locProp$remove_date[idxLoc],- |
-
| 274 | -19x | -
- context=ctxt,- |
-
| 275 | -19x | -
- active_periods=NA,- |
-
| 276 | -19x | -
- IS_Processing_Default_Start_Date=timeProcBgnDflt,- |
-
| 277 | -19x | -
- location_id=propFill[['Required Asset Management Location ID']],- |
-
| 278 | -19x | -
- location_code=propFill[['Required Asset Management Location Code']],- |
-
| 279 | -19x | -
- HOR=propFill$HOR,- |
-
| 280 | -19x | -
- VER=propFill$VER,- |
-
| 281 | -19x | -
- dataRate=propFill[['Data Rate']],- |
-
| 282 | -19x | -
- stringsAsFactors = FALSE)- |
-
| 283 | -19x | -
- rptIdx$active_periods <- timeActv # Add in the (potential) data frame of active periods.- |
-
| 284 | -- |
- - |
-
| 285 | -19x | -
- rpt <- base::rbind(rpt,rptIdx)- |
-
| 286 | -- |
- }- |
-
| 287 | -- |
- - |
-
| 288 | -18x | -
- return(rpt)- |
-
| 289 | -- |
- - |
-
| 290 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Parse input argument strings into list of named parameters- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Parse the input arguments as read from the command line into a named- |
-
| 9 | -- |
- #' parameter list. Each input argument must be a character string in the format "Para=value",- |
-
| 10 | -- |
- #' where "Para" is the intended parameter name and "value" is the value of the parameter. Options- |
-
| 11 | -- |
- #' include: checking for expected parameter names, parsing of each parameter value into a vector,- |
-
| 12 | -- |
- #' reading the parameter value(s) from environment variables, conversion of each paramater from the- |
-
| 13 | -- |
- #' default class of character to any other recognized class, and logging via the lgr package.- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @param arg Character vector of argument strings, each in the format "Para=value", where "Para"- |
-
| 16 | -- |
- #' is the intended parameter name and "value" is the value of the parameter. If the value string contains- |
-
| 17 | -- |
- #' pipes (|), the value string will be split into a character vector with | and/or : used as the delimiter.- |
-
| 18 | -- |
- #' If a value string begins with a $ (e.g. "$DIR_IN"), the value of the parameter will be assigned from- |
-
| 19 | -- |
- #' the system environment variable matching the value string. Note that the value string is first- |
-
| 20 | -- |
- #' split into a character vector based on the delimiters, then each relevant string of the resultant- |
-
| 21 | -- |
- #' character vector is evaluated as an environment variable.- |
-
| 22 | -- |
- #' @param NameParaReqd character vector of required parameter names as a check on the output parameter- |
-
| 23 | -- |
- #' list. Defaults to NULL, in which case there are no required parameters.- |
-
| 24 | -- |
- #' @param NameParaOptn character vector of optional parameter names as a check on the output parameter- |
-
| 25 | -- |
- #' list. Defaults to NULL, in which case there are no optional parameters. If both NameParaReqd and- |
-
| 26 | -- |
- #' NameParaOptn are NULL, no check is performed on the output parameter list.- |
-
| 27 | -- |
- #' @param ValuParaOptn Named list of default values (in desired class) for the optional parameter arguments- |
-
| 28 | -- |
- #' in NameParaOptn. Defaults to NULL. Any optional arguments missing from this list will not be included- |
-
| 29 | -- |
- #' in the output parameter list if they are not provided by the user.- |
-
| 30 | -- |
- #' @param TypePara Named list of R classes to convert the corresponding parameter to. For example,- |
-
| 31 | -- |
- #' TypePara=list(Para1="numeric") will attempt to convert the value of Para1 to numeric. Defaults to- |
-
| 32 | -- |
- #' NULL, in which case no type conversion will be attempted.- |
-
| 33 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 34 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 35 | -- |
- #' created and used within the function.- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @return A named list of parameters.- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @references- |
-
| 40 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 41 | -- | - - | -
| 42 | -- |
- #' @keywords Currently none- |
-
| 43 | -- | - - | -
| 44 | -- |
- #' @examples- |
-
| 45 | -- |
- #' arg <- c("DirIn=/scratch/test","DirOut=$DIR_OUT","Freq=10|20")
- |
-
| 46 | -- |
- #' NameParaReqd <- c("DirIn","DirOut")
- |
-
| 47 | -- |
- #' NameParaOptn <- "Freq"- |
-
| 48 | -- |
- #' TypePara<-list(DirIn="character",DirOut="character",Freq="numeric")- |
-
| 49 | -- |
- #' Para <- NEONprocIS.base::def.arg.pars(arg=arg,NameParaReqd=NameParaReqd,NameParaOptn=NameParaOptn,TypePara=TypePara)- |
-
| 50 | -- |
- #' # Result- |
-
| 51 | -- |
- #' # > Para- |
-
| 52 | -- |
- #' # $DirIn- |
-
| 53 | -- |
- #' # [1] "/scratch/test"- |
-
| 54 | -- |
- #'- |
-
| 55 | -- |
- #' # $DirOut- |
-
| 56 | -- |
- #' [1] "/scratch/test/out" # Read of environment variable $DIR_OUT- |
-
| 57 | -- |
- #'- |
-
| 58 | -- |
- #' # $Freq- |
-
| 59 | -- |
- #' # [1] 10 20- |
-
| 60 | -- | - - | -
| 61 | -- | - - | -
| 62 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.vect.pars.pair}}
- |
-
| 63 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.log.init}}
- |
-
| 64 | -- | - - | -
| 65 | -- |
- #' @export- |
-
| 66 | -- | - - | -
| 67 | -- |
- # changelog and author contributions / copyrights- |
-
| 68 | -- |
- # Cove Sturtevant (2019-09-24)- |
-
| 69 | -- |
- # original creation- |
-
| 70 | -- |
- # Cove Sturtevant (2019-10-01)- |
-
| 71 | -- |
- # added additional parsing of argument string by colon (along with pipe)- |
-
| 72 | -- |
- # Cove Sturtevant (2019-10-16)- |
-
| 73 | -- |
- # added input of default parameter values- |
-
| 74 | -- |
- # Cove Sturtevant (2020-02-11)- |
-
| 75 | -- |
- # limit splitting of parameter string to a single colon or pipe (i.e. do not split double colon or double pipe)- |
-
| 76 | -- |
- ##############################################################################################- |
-
| 77 | -- |
- def.arg.pars <- function(arg,- |
-
| 78 | -- |
- NameParaReqd=NULL,- |
-
| 79 | -- |
- NameParaOptn=NULL,- |
-
| 80 | -- |
- ValuParaOptn=NULL,- |
-
| 81 | -- |
- TypePara=NULL, # Named list of intended class for each parameter. Conversion will be attempted- |
-
| 82 | -- |
- log=NULL){
- |
-
| 83 | -- | - - | -
| 84 | -- |
- # initialize logging if necessary- |
-
| 85 | -9x | -
- if (base::is.null(log)) {
- |
-
| 86 | -9x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 87 | -- |
- }- |
-
| 88 | -- |
- - |
-
| 89 | -- |
- # Error check- |
-
| 90 | -9x | -
- if(base::class(arg) != "character"){
- |
-
| 91 | -! | -
- msg <- "Input argument vector must be of class character."- |
-
| 92 | -! | -
- log$fatal(msg)- |
-
| 93 | -! | -
- stop()- |
-
| 94 | -- |
- }- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- # Error check- |
-
| 97 | -9x | -
- nameValuOptn <- base::names(ValuParaOptn)- |
-
| 98 | -9x | -
- chkOptn <- !(nameValuOptn %in% NameParaOptn)- |
-
| 99 | -9x | -
- if(base::length(chkOptn) > 0 && base::sum(chkOptn) != 0){
- |
-
| 100 | -1x | -
- msg <- base::paste0('Default parameter value(s) were provided for: ',base::paste0(nameValuOptn[chkOptn],collapse=','),', but these parameters were not listed in NameParaOptn. Check inputs.')
- |
-
| 101 | -1x | -
- log$fatal(msg)- |
-
| 102 | -1x | -
- stop()- |
-
| 103 | -- |
- }- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- # Intialize list of parameters- |
-
| 106 | -8x | -
- Para <- base::list()- |
-
| 107 | -- |
- - |
-
| 108 | -8x | -
- for(idxArg in arg){
- |
-
| 109 | -- |
- - |
-
| 110 | -- |
- # Parse before/after equals sign- |
-
| 111 | -19x | -
- splt <- base::strsplit(idxArg,"=")[[1]]- |
-
| 112 | -- |
- - |
-
| 113 | -- |
- # Trim whitespace- |
-
| 114 | -19x | -
- splt <- base::trimws(splt)- |
-
| 115 | -- |
- - |
-
| 116 | -- |
- # Error check- |
-
| 117 | -19x | -
- if(base::length(splt) != 2){
- |
-
| 118 | -2x | -
- msg <- base::paste0('There must be one equals sign (=) in each argument. Parameter ',idxArg, ' does not fulfill this requirement.')
- |
-
| 119 | -2x | -
- log$fatal(msg)- |
-
| 120 | -2x | -
- stop()- |
-
| 121 | -- |
- }- |
-
| 122 | -- |
- - |
-
| 123 | -- |
- # Split the parameter value into a character vector delimited by pipes or colons, but not splitting if more than one pipe or colon- |
-
| 124 | -17x | -
- valu <- base::strsplit(splt[2],"(?<![:|])[:|]{1}(?![:|])",perl=TRUE)[[1]]
- |
-
| 125 | -- |
- - |
-
| 126 | -- |
- # Evaluate environment variables- |
-
| 127 | -17x | -
- for(idxValu in base::seq_len(base::length(valu))){
- |
-
| 128 | -22x | -
- if(base::substr(valu[idxValu],start=1,stop=1) == "$"){
- |
-
| 129 | -- |
- # Read the parameter value from system environment variable- |
-
| 130 | -1x | -
- varEnv <- base::substr(valu[idxValu],start=2,stop=base::nchar(valu[idxValu]))- |
-
| 131 | -1x | -
- valu[idxValu] <- base::Sys.getenv(x=varEnv)- |
-
| 132 | -- |
- - |
-
| 133 | -- |
- # Error check- |
-
| 134 | -1x | -
- if(base::nchar(valu[idxValu]) == 0){
- |
-
| 135 | -1x | -
- msg <- base::paste0('Input parameter ',splt[1], ' was indicated to be read from system environment variable ',varEnv, ' but it cannot be found.')
- |
-
| 136 | -1x | -
- log$fatal(msg)- |
-
| 137 | -1x | -
- stop()- |
-
| 138 | -- |
- }- |
-
| 139 | -- |
- }- |
-
| 140 | -- |
- }- |
-
| 141 | -- |
- - |
-
| 142 | -- |
- # Assign the parameter- |
-
| 143 | -16x | -
- Para[[splt[1]]] <- valu- |
-
| 144 | -- |
- - |
-
| 145 | -- |
- }- |
-
| 146 | -- |
- - |
-
| 147 | -- |
- # Check if the resultant parameter list meets our expectations- |
-
| 148 | -5x | -
- if(!base::is.null(NameParaReqd)){
- |
-
| 149 | -5x | -
- inPara <- NameParaReqd %in% base::names(Para)- |
-
| 150 | -5x | -
- if(base::sum(!inPara) > 0){
- |
-
| 151 | -1x | -
- msg <- base::paste0('Missing required input parameter(s) ', base::paste0(NameParaReqd[!inPara],collapse=','),
- |
-
| 152 | -1x | -
- '. Check inputs.')- |
-
| 153 | -1x | -
- log$fatal(msg)- |
-
| 154 | -1x | -
- stop()- |
-
| 155 | -- |
- - |
-
| 156 | -- |
- }- |
-
| 157 | -- |
- }- |
-
| 158 | -4x | -
- if(!base::is.null(NameParaReqd) || !base::is.null(NameParaOptn)){
- |
-
| 159 | -4x | -
- outPara <- !(base::names(Para) %in% c(NameParaReqd,NameParaOptn))- |
-
| 160 | -4x | -
- if(base::sum(outPara) > 0){
- |
-
| 161 | -1x | -
- msg <- base::paste0('Input parameter(s) ', base::paste0(base::names(Para)[outPara],collapse=','),
- |
-
| 162 | -1x | -
- ' are not in the list of acceptable parameters (NameParaReqd & NameParaOptn). Check inputs.')- |
-
| 163 | -1x | -
- log$fatal(msg)- |
-
| 164 | -1x | -
- stop()- |
-
| 165 | -- |
- - |
-
| 166 | -- |
- }- |
-
| 167 | -- |
- }- |
-
| 168 | -- |
- - |
-
| 169 | -- |
- # Resultant parameter list so far- |
-
| 170 | -3x | -
- nameParaOut <- base::names(Para)- |
-
| 171 | -- |
- - |
-
| 172 | -- |
- # Assign defaults to optional parameters- |
-
| 173 | -3x | -
- for(idxNamePara in base::setdiff(nameValuOptn,nameParaOut)){
- |
-
| 174 | -! | -
- Para[[idxNamePara]] <- ValuParaOptn[[idxNamePara]]- |
-
| 175 | -- |
- }- |
-
| 176 | -- | - - | -
| 177 | -- |
- # Convert the inputs to the intended types- |
-
| 178 | -3x | -
- if(!base::is.null(TypePara)){
- |
-
| 179 | -3x | -
- if(base::class(TypePara) != "list"){
- |
-
| 180 | -1x | -
- msg <- base::paste0('TypePara must be a named list of intended classes (as a character string) for each parameter.')
- |
-
| 181 | -1x | -
- log$fatal(msg)- |
-
| 182 | -1x | -
- stop()- |
-
| 183 | -- |
- - |
-
| 184 | -- |
- }- |
-
| 185 | -2x | -
- inPara <- base::names(TypePara) %in% base::names(Para)- |
-
| 186 | -2x | -
- if(base::sum(!inPara) > 0){
- |
-
| 187 | -1x | -
- msg <- base::paste0('List name(s): ',base::paste0(base::names(TypePara)[!inPara],collapse=','),
- |
-
| 188 | -1x | -
- ' of TypePara do not match the names of any parameters. Check inputs.')- |
-
| 189 | -1x | -
- log$fatal(msg)- |
-
| 190 | -1x | -
- stop()- |
-
| 191 | -- |
- - |
-
| 192 | -- |
- }- |
-
| 193 | -- |
- - |
-
| 194 | -- |
- # Convert to appropriate class- |
-
| 195 | -1x | -
- for(idxNamePara in base::names(TypePara)){
- |
-
| 196 | -1x | -
- base::suppressWarnings(base::class(Para[[idxNamePara]]) <- TypePara[[idxNamePara]])- |
-
| 197 | -- |
- }- |
-
| 198 | -- |
- }- |
-
| 199 | -- |
- - |
-
| 200 | -1x | -
- return(Para)- |
-
| 201 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Copy a directory with a symbolic link- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Copy a source directory to a destination directory with a symbolic link- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param DirSrc String vector. Source directories. All files in these source directories will be copied to the- |
-
| 11 | -- |
- #' destination directories.- |
-
| 12 | -- |
- #' @param DirDest String value or vector. Destination director(ies). If not of length 1, must be same length- |
-
| 13 | -- |
- #' as DirDest, each index corresponding to the same index of DirDest. NOTE: DirDest should be the parent of the- |
-
| 14 | -- |
- #' distination directories. For example, to create a link from source /parent/child/ to /newparent/child,- |
-
| 15 | -- |
- #' DirSrc='/parent/child/' and DirDest='/newparent/'- |
-
| 16 | -- |
- #' @param LnkSubObj Logical (default FALSE). TRUE: Instead of symbolically linking the entire directory DirSrc- |
-
| 17 | -- |
- #' to DirDest, create the 'child' directory in DirDest and link each individual object.- |
-
| 18 | -- |
- #' For example, if DirSrc='/parent/child/' and DirDest='/newparent/', the 'child' directory will be created in- |
-
| 19 | -- |
- #' DirDest ('/newparent/child') and each individual object in '/parent/child/' will be symbolically linked in
- |
-
| 20 | -- |
- #' '/newparent/child'. Note that the output directory structure will be the same regardless of the choice here,- |
-
| 21 | -- |
- #' but TRUE is useful for situations in which you want to write additional objects in '/newparent/child/'- |
-
| 22 | -- |
- #' either prior to executing this function or afterward. TRUE will allow you to do this, whereas- |
-
| 23 | -- |
- #' FALSE will not.- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @return No output from this function other than performing the intended action.- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @references Currently none- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @keywords Currently none- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @examples- |
-
| 34 | -- |
- #' def.dir.copy.symb(DirSrc='/scratch/pfs/proc_group/prt/27134/2019/01/01',DirDest='pfs/out/prt/27134/2019/01')- |
-
| 35 | -- | - - | -
| 36 | -- | - - | -
| 37 | -- |
- #' @seealso Currently none- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @export- |
-
| 40 | -- | - - | -
| 41 | -- |
- # changelog and author contributions / copyrights- |
-
| 42 | -- |
- # Cove Sturtevant (2019-07-02)- |
-
| 43 | -- |
- # original creation- |
-
| 44 | -- |
- # Cove Sturtevant (2020-02-04)- |
-
| 45 | -- |
- # added logging- |
-
| 46 | -- |
- # Cove Sturtevant (2021-06-07)- |
-
| 47 | -- |
- # add support for relative paths- |
-
| 48 | -- |
- # Cove Sturtevant (2022-02-10)- |
-
| 49 | -- |
- # add option to link individual objects with a directory rather the directory itself- |
-
| 50 | -- |
- ##############################################################################################- |
-
| 51 | -- |
- def.dir.copy.symb <- function(DirSrc,- |
-
| 52 | -- |
- DirDest,- |
-
| 53 | -- |
- LnkSubObj=FALSE,- |
-
| 54 | -- |
- log=NULL){
- |
-
| 55 | -- |
- - |
-
| 56 | -- |
- # initialize logging if necessary- |
-
| 57 | -3x | -
- if (base::is.null(log)) {
- |
-
| 58 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 59 | -- |
- }- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # Do some error checking- |
-
| 62 | -3x | -
- numDirSrc <- base::length(DirSrc)- |
-
| 63 | -3x | -
- numDirDest <- base::length(DirDest)- |
-
| 64 | -3x | -
- if(numDirDest != 1 && numDirSrc != numDirDest){
- |
-
| 65 | -1x | -
- log$error('Lengths of DirSrc and DirDest must be equal if length of DirDest is not equal to 1.')
- |
-
| 66 | -1x | -
- base::stop()- |
-
| 67 | -- |
- }- |
-
| 68 | -- | - - | -
| 69 | -- |
- # Check that the source directories exist. Remove those that don't- |
-
| 70 | -2x | -
- exstDirSrc <- base::unlist(base::lapply(DirSrc,base::dir.exists))- |
-
| 71 | -2x | -
- if(!base::all(exstDirSrc)){
- |
-
| 72 | -1x | -
- log$warn(base::paste0("The following source directories do not exist and will not be symbolically linked: ",
- |
-
| 73 | -1x | -
- base::paste0(DirSrc[!exstDirSrc],collapse=',')))- |
-
| 74 | -1x | -
- DirSrc <- DirSrc[exstDirSrc]- |
-
| 75 | -- |
- - |
-
| 76 | -1x | -
- if(numDirDest > 1){
- |
-
| 77 | -! | -
- DirDest <- DirDest[exstDirSrc]- |
-
| 78 | -- |
- }- |
-
| 79 | -- |
- }- |
-
| 80 | -- |
- - |
-
| 81 | -! | -
- if(base::length(DirSrc) == 0){return()}
- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- # Check for relative paths- |
-
| 84 | -2x | -
- rltvDirSrc <- base::substr(x=DirSrc,start=1,stop=1) != '/'- |
-
| 85 | -2x | -
- rltvDirDest <- base::substr(x=DirDest,start=1,stop=1) != '/'- |
-
| 86 | -- |
- - |
-
| 87 | -- |
- # Create the parent destination directories- |
-
| 88 | -2x | -
- rptDir <- base::suppressWarnings(base::lapply(DirDest,base::dir.create,recursive=TRUE))- |
-
| 89 | -- |
- - |
-
| 90 | -2x | -
- if(LnkSubObj==TRUE){
- |
-
| 91 | -- |
- # Goal: link the individual objects in each DirSrc to dirDest- |
-
| 92 | -- |
- - |
-
| 93 | -- |
- # Create the terminal directories of DirSrc within DirDest- |
-
| 94 | -1x | -
- nameDirEnd <- base::unlist(- |
-
| 95 | -1x | -
- base::lapply(- |
-
| 96 | -1x | -
- base::strsplit(DirSrc,split='/'),- |
-
| 97 | -1x | -
- utils::tail,- |
-
| 98 | -1x | -
- n=1- |
-
| 99 | -- |
- )- |
-
| 100 | -- |
- )- |
-
| 101 | -1x | -
- dirDest <- base::paste0(DirDest,'/',nameDirEnd)- |
-
| 102 | -1x | -
- rptDir <- base::suppressWarnings(base::lapply(dirDest,base::dir.create,recursive=TRUE))- |
-
| 103 | -- |
- - |
-
| 104 | -- |
- # Set up the command to link the individual objects in each DirSrc to dirDest- |
-
| 105 | -1x | -
- cmdCopy <- base::paste0('ln -s ',base::paste0(DirSrc),'/* ',base::paste0(dirDest))
- |
-
| 106 | -- | - - | -
| 107 | -- |
- # Modify the copy command for the relative paths- |
-
| 108 | -1x | -
- setRltv <- rltvDirSrc | rltvDirDest- |
-
| 109 | -1x | -
- cmdCopy[setRltv] <- base::paste0('ln -s -r ',base::paste0(DirSrc[setRltv]),'/* ',base::paste0(dirDest[setRltv]))
- |
-
| 110 | -- |
- - |
-
| 111 | -- |
- # perform symbolic link- |
-
| 112 | -1x | -
- rptCopy <- base::lapply(cmdCopy,base::system) # Symbolically link the directories- |
-
| 113 | -- |
- - |
-
| 114 | -- |
- # Report success/failure- |
-
| 115 | -1x | -
- sccs <- rptCopy==0- |
-
| 116 | -1x | -
- if(base::any(sccs)){
- |
-
| 117 | -1x | -
- log$info(base::paste0('Unmodified objects in ',DirSrc[sccs], ' symbolically linked to ',dirDest[sccs]))
- |
-
| 118 | -- |
- }- |
-
| 119 | -1x | -
- if(base::any(!sccs)){
- |
-
| 120 | -! | -
- log$warn(base::paste0('At least some of the objects in ',DirSrc[!sccs], ' could not be symbolically linked to ',dirDest[!sccs],
- |
-
| 121 | -! | -
- '. Permissions may be inadequate or objects with the same name might already exist in the destination directory.'))- |
-
| 122 | -- |
- }- |
-
| 123 | -- |
- - |
-
| 124 | -- |
- } else {
- |
-
| 125 | -- |
- # Goal: Link the whole directories of DirSrc over to DirDest- |
-
| 126 | -- |
- - |
-
| 127 | -1x | -
- if(base::length(DirDest) == 1){
- |
-
| 128 | -1x | -
- dirDest <- base::rep(DirDest,times=base::length(DirSrc))- |
-
| 129 | -- |
- } else {
- |
-
| 130 | -! | -
- dirDest <- DirDest- |
-
| 131 | -- |
- }- |
-
| 132 | -- | - - | -
| 133 | -- |
- # Set up the command to copy- |
-
| 134 | -1x | -
- cmdCopy <- base::paste0('ln -s ',base::paste0(DirSrc),' ',base::paste0(dirDest))
- |
-
| 135 | -- |
- - |
-
| 136 | -- |
- # Modify the copy command for the relative paths- |
-
| 137 | -1x | -
- setRltv <- rltvDirSrc | rltvDirDest- |
-
| 138 | -1x | -
- cmdCopy[setRltv] <- base::paste0('ln -s -r ',base::paste0(DirSrc[setRltv]),' ',base::paste0(dirDest[setRltv]))
- |
-
| 139 | -- |
- - |
-
| 140 | -- |
- # perform symbolic link- |
-
| 141 | -1x | -
- rptCopy <- base::lapply(cmdCopy,base::system) # Symbolically link the directories- |
-
| 142 | -- |
- - |
-
| 143 | -- |
- # Report success/failure- |
-
| 144 | -1x | -
- sccs <- rptCopy==0- |
-
| 145 | -1x | -
- if(base::any(sccs)){
- |
-
| 146 | -1x | -
- log$info(base::paste0('Unmodified ',DirSrc[sccs], ' symbolically linked into ',dirDest[sccs]))
- |
-
| 147 | -- |
- }- |
-
| 148 | -1x | -
- if(base::any(!sccs)){
- |
-
| 149 | -! | -
- log$warn(base::paste0(DirSrc[!sccs], ' could not be symbolically linked into ',dirDest[!sccs],- |
-
| 150 | -! | -
- '. Permissions may be inadequate or objects with the same name might already exist in the destination directory.'))- |
-
| 151 | -- |
- }- |
-
| 152 | -- |
- }- |
-
| 153 | -- |
- - |
-
| 154 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Create Parquet schema from Avro schema- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Create a arrow schema object from an avro schema file or json string.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param FileSchm String. Optional. Full or relative path to schema file. One of FileSchm or Schm must be- |
-
| 11 | -- |
- #' provided.- |
-
| 12 | -- |
- #' @param Schm String. Optional. Json formatted string of the AVRO file schema. One of FileSchm or Schm must- |
-
| 13 | -- |
- #' be provided. If both Schm and FileSchm are provided, Schm will be ignored.- |
-
| 14 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 15 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 16 | -- |
- #' created for use within this function.- |
-
| 17 | -- |
- #'- |
-
| 18 | -- |
- #' @return An Apache Arrow Schema object containing a parquet schema representation of the avro schema.- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @references- |
-
| 21 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @keywords Currently none- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @examples Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @seealso \link[arrow]{data-type}
- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @export- |
-
| 30 | -- | - - | -
| 31 | -- |
- # changelog and author contributions / copyrights- |
-
| 32 | -- |
- # Cove Sturtevant (2023-02-20)- |
-
| 33 | -- |
- # original creation- |
-
| 34 | -- |
- ##############################################################################################- |
-
| 35 | -- |
- def.schm.parq.from.schm.avro <- function(FileSchm=NULL,- |
-
| 36 | -- |
- Schm=NULL,- |
-
| 37 | -- |
- log=NULL- |
-
| 38 | -- |
- ){
- |
-
| 39 | -- |
- # initialize logging if necessary- |
-
| 40 | -8x | -
- if (base::is.null(log)) {
- |
-
| 41 | -6x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 42 | -- |
- }- |
-
| 43 | -- |
- - |
-
| 44 | -- |
- # Parse the avro schema- |
-
| 45 | -8x | -
- typeVar <- NEONprocIS.base::def.schm.avro.pars(FileSchm=FileSchm,- |
-
| 46 | -8x | -
- Schm=Schm,- |
-
| 47 | -8x | -
- log=log- |
-
| 48 | -8x | -
- )$var- |
-
| 49 | -6x | -
- numRow <- base::nrow(typeVar)- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # Create each field in the schema- |
-
| 52 | -6x | -
- fldSchm <- base::vector(numRow,mode='list') # Initialize list of schema fields- |
-
| 53 | -6x | -
- for(idx in base::seq_len(numRow)){
- |
-
| 54 | -- |
- - |
-
| 55 | -35x | -
- nameField <- typeVar$name[idx]- |
-
| 56 | -35x | -
- typeData <- typeVar$type[idx]- |
-
| 57 | -35x | -
- typeData <- base::strsplit(typeData,'|',fixed=TRUE)[[1]]- |
-
| 58 | -- | - - | -
| 59 | -- |
- # See documentation on arrow::data-type- |
-
| 60 | -35x | -
- if (base::any(base::grepl('timestamp-millis', typeData))) {
- |
-
| 61 | -5x | -
- typeArrw <- arrow::timestamp(unit = "ms")- |
-
| 62 | -- |
- - |
-
| 63 | -30x | -
- } else if (base::any(base::grepl('timestamp-micro', typeData))) {
- |
-
| 64 | -1x | -
- typeArrw <- arrow::timestamp(unit = "us")- |
-
| 65 | -- |
- - |
-
| 66 | -29x | -
- } else if (base::any(base::grepl('timestamp-nano', typeData))) {
- |
-
| 67 | -1x | -
- typeArrw <- arrow::timestamp(unit = "ns")- |
-
| 68 | -- |
- - |
-
| 69 | -28x | -
- } else if (base::any(base::grepl('time', typeData) || base::grepl('date', typeData))) {
- |
-
| 70 | -1x | -
- typeArrw <- arrow::timestamp(unit = "s")- |
-
| 71 | -- |
- - |
-
| 72 | -27x | -
- } else if (base::any(base::grepl('float', typeData))) {
- |
-
| 73 | -5x | -
- typeArrw <- arrow::float()- |
-
| 74 | -- |
- - |
-
| 75 | -22x | -
- } else if (base::any(typeData == 'double')) {
- |
-
| 76 | -1x | -
- typeArrw <- arrow::double()- |
-
| 77 | -- |
- - |
-
| 78 | -21x | -
- } else if (base::any(typeData == 'uint8')) {
- |
-
| 79 | -1x | -
- typeArrw <- arrow::uint8()- |
-
| 80 | -- |
- - |
-
| 81 | -20x | -
- } else if (base::any(typeData == 'uint16')) {
- |
-
| 82 | -1x | -
- typeArrw <- arrow::uint16()- |
-
| 83 | -- |
- - |
-
| 84 | -19x | -
- } else if (base::any(typeData == 'uint32')) {
- |
-
| 85 | -1x | -
- typeArrw <- arrow::uint32()- |
-
| 86 | -- |
- - |
-
| 87 | -18x | -
- } else if (base::any(typeData == 'uint64')) {
- |
-
| 88 | -1x | -
- typeArrw <- arrow::uint64()- |
-
| 89 | -- |
- - |
-
| 90 | -17x | -
- } else if (base::any(typeData == 'int8')) {
- |
-
| 91 | -1x | -
- typeArrw <- arrow::int8()- |
-
| 92 | -- |
- - |
-
| 93 | -16x | -
- } else if (base::any(typeData == 'int16')) {
- |
-
| 94 | -1x | -
- typeArrw <- arrow::int16()- |
-
| 95 | -- |
- - |
-
| 96 | -15x | -
- } else if (base::any(typeData == 'int32')) {
- |
-
| 97 | -1x | -
- typeArrw <- arrow::int32()- |
-
| 98 | -- |
- - |
-
| 99 | -14x | -
- } else if (base::any(typeData == 'int64') || base::any(typeData == 'long')) {
- |
-
| 100 | -1x | -
- typeArrw <- arrow::int64()- |
-
| 101 | -- |
- - |
-
| 102 | -13x | -
- } else if (base::any(base::grepl('uint', typeData))) {
- |
-
| 103 | -1x | -
- typeArrw <- arrow::uint32()- |
-
| 104 | -- |
- - |
-
| 105 | -12x | -
- } else if (base::any(base::grepl('int', typeData))) {
- |
-
| 106 | -1x | -
- typeArrw <- arrow::int32()- |
-
| 107 | -- |
- - |
-
| 108 | -11x | -
- } else if (base::any(typeData == 'string')) {
- |
-
| 109 | -7x | -
- typeArrw <- arrow::string()- |
-
| 110 | -- |
- - |
-
| 111 | -4x | -
- } else if (base::any(typeData == 'boolean')) {
- |
-
| 112 | -1x | -
- typeArrw <- arrow::boolean()- |
-
| 113 | -- |
- - |
-
| 114 | -3x | -
- } else if (base::any(typeData == 'fixed')) {
- |
-
| 115 | -- |
- # Fixed size binary- |
-
| 116 | -1x | -
- size <- typeData[which(typeData == 'fixed')+1]- |
-
| 117 | -1x | -
- typeArrw <- arrow::fixed_size_binary(base::as.integer(size))- |
-
| 118 | -- |
- - |
-
| 119 | -2x | -
- } else if (base::any(typeData == 'bytes')) {
- |
-
| 120 | -- |
- # Binary- |
-
| 121 | -1x | -
- typeArrw <- arrow::binary()- |
-
| 122 | -- |
- - |
-
| 123 | -- |
- } else {
- |
-
| 124 | -1x | -
- typeArrw <- arrow::null()- |
-
| 125 | -1x | -
- log$warn(base::paste0('Data type(s) [',base::paste0(typeData,collapse=','),'] not recognized for field name [',nameField,']. Setting parquet schema type to null, which will likely result in NA data.'))
- |
-
| 126 | -- |
- }- |
-
| 127 | -- |
- - |
-
| 128 | -- |
- # Place in the list- |
-
| 129 | -34x | -
- if (base::any(typeData == 'null')){
- |
-
| 130 | -22x | -
- nullable = TRUE- |
-
| 131 | -- |
- } else {
- |
-
| 132 | -12x | -
- nullable = FALSE- |
-
| 133 | -- |
- }- |
-
| 134 | -34x | -
- fldSchm[[idx]] <- arrow::field(nameField, typeArrw, nullable = nullable)- |
-
| 135 | -- |
- }- |
-
| 136 | -- |
- - |
-
| 137 | -- |
- # Create schema- |
-
| 138 | -- |
- # Example- |
-
| 139 | -- |
- # arrow::schema(- |
-
| 140 | -- |
- # arrow::field("c", arrow::bool(),nullable = TRUE),
- |
-
| 141 | -- |
- # )- |
-
| 142 | -5x | -
- schm <- base::do.call(arrow::schema, fldSchm)- |
-
| 143 | -- | - - | -
| 144 | -- |
- - |
-
| 145 | -5x | -
- return(schm)- |
-
| 146 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Create sequence of time bins as a difftime object- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Create sequence of time bins as a difftime object offset from zero. This allows the- |
-
| 9 | -- |
- #' time differences to be added to an arbitrary start time.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param WndwBin WndwAgr A difftime object indicating the bin size (e.g. base::as.difftime(30,units="mins"))- |
-
| 12 | -- |
- #' @param WndwTime A difftime object indicating the total length of time to bin (e.g. base::as.difftime(1,units='days'))- |
-
| 13 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 14 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which no logger other than- |
-
| 15 | -- |
- #' standard R error messaging will be used.- |
-
| 16 | -- |
- #'- |
-
| 17 | -- |
- #' @return A list of:- |
-
| 18 | -- |
- #' timeBgnDiff A difftime object providing the start times for each bin as a time offset from zero- |
-
| 19 | -- |
- #' timeEndDiff A difftime object providing the end times for each bin as a time offset from zero- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @references- |
-
| 22 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @keywords Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @examples- |
-
| 27 | -- |
- #' WndwBin <- base::as.difftime(30,units="mins")- |
-
| 28 | -- |
- #' WndwTime <- base::as.difftime(1,units='days')- |
-
| 29 | -- |
- #' NEONprocIS.base::def.time.bin.diff(WndwBin=WndwBin,WndwTime=WndwTime)- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.log.init}}
- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @export- |
-
| 34 | -- | - - | -
| 35 | -- |
- # changelog and author contributions / copyrights- |
-
| 36 | -- |
- # Cove Sturtevant (2019-12-19)- |
-
| 37 | -- |
- # original creation- |
-
| 38 | -- |
- # Cove Sturtevant (2020-07-29)- |
-
| 39 | -- |
- # force units of output difftime objects to be the same as WndwBin- |
-
| 40 | -- |
- ##############################################################################################- |
-
| 41 | -- |
- def.time.bin.diff <- function(WndwBin,- |
-
| 42 | -- |
- WndwTime,- |
-
| 43 | -- |
- log=NULL- |
-
| 44 | -- |
- ){
- |
-
| 45 | -- |
- - |
-
| 46 | -3x | -
- timeDmmyBgn <- base::as.POSIXlt('1970-01-01',tz='GMT')
- |
-
| 47 | -3x | -
- timeDmmyEnd <- timeDmmyBgn + WndwTime- |
-
| 48 | -3x | -
- timeBgnDiff <- list()- |
-
| 49 | -3x | -
- timeEndDiff <- list()- |
-
| 50 | -- | - - | -
| 51 | -- |
- # Time series of binning windows- |
-
| 52 | -3x | -
- timeBgnSeq <- base::as.POSIXlt(base::seq.POSIXt(from=timeDmmyBgn,to=timeDmmyEnd,by=base::format(WndwBin)))- |
-
| 53 | -3x | -
- timeBgnSeq <- utils::head(timeBgnSeq,n=-1) # Lop off the last one at timeEnd- |
-
| 54 | -3x | -
- timeEndSeq <- timeBgnSeq + WndwBin- |
-
| 55 | -3x | -
- if(utils::tail(timeEndSeq,n=1) != timeDmmyEnd){
- |
-
| 56 | -1x | -
- msg <- (base::paste0('WndwBin must be an even divisor of WndwTime. A WndwBin of ',
- |
-
| 57 | -1x | -
- WndwBin,' does not fit this requirement. Check inputs.'))- |
-
| 58 | -1x | -
- if(!base::is.null(log)){
- |
-
| 59 | -! | -
- log$fatal(msg)- |
-
| 60 | -- |
- }- |
-
| 61 | -1x | -
- stop(msg)- |
-
| 62 | -- | - - | -
| 63 | -- |
- }- |
-
| 64 | -- |
- - |
-
| 65 | -2x | -
- timeBgnDiff <- base::difftime(timeBgnSeq,timeDmmyBgn,units=base::attr(WndwBin,'units')) # Add to timeBgn of each day to represent the starting time sequence- |
-
| 66 | -2x | -
- timeEndDiff <- base::difftime(timeEndSeq,timeDmmyBgn,units=base::attr(WndwBin,'units')) # Add to timeBgn of each day to represent the end time sequence- |
-
| 67 | -- | - - | -
| 68 | -2x | -
- return(base::list(timeBgnDiff=timeBgnDiff,timeEndDiff=timeEndDiff))- |
-
| 69 | -- |
- }- |
-
| 1 | -- |
- ###################################################################################################- |
-
| 2 | -- |
- #' @title Validate vector- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Mija Choi \email{choim@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Validate a vector to check that it is a vector, with optional tests for empty and numeric.- |
-
| 9 | -- |
- #' Returns True if passes all checks. FALSE otherwise.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param vectIn Input vector to be validated- |
-
| 12 | -- |
- #' @param TestEmpty Boolean. TRUE to test whether the vector is empty (function will return FALSE if empty).- |
-
| 13 | -- |
- #' @param TestNumc Boolean. TRUE to test whether the vector is numeric or logical (function will return FALSE if not numeric or logical (which converts to 0 or 1)).- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @return Boolean. True if the input vector is not empty. FALSE otherwise. \cr- |
-
| 16 | -- | - - | -
| 17 | -- |
- #' @references Currently none- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @keywords Currently none- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @examples Currently none- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 24 | -- |
- #'- |
-
| 25 | -- |
- #' @export- |
-
| 26 | -- | - - | -
| 27 | -- |
- # changelog and author contributions / copyrights- |
-
| 28 | -- |
- # Mija Choi (2020-01-07)- |
-
| 29 | -- |
- # original creation- |
-
| 30 | -- |
- # Cove Sturtevant (2023-02-03)- |
-
| 31 | -- |
- # add logging- |
-
| 32 | -- |
- # add check for vector and options to check empty and numeric- |
-
| 33 | -- |
- # Cove Sturtevant (2024-04-24)- |
-
| 34 | -- |
- # Allow logical values when testing for numeric (which convert to 0 or 1)- |
-
| 35 | -- |
- ##############################################################################################- |
-
| 36 | -- | - - | -
| 37 | -- |
- def.validate.vector <- function(vectIn,TestEmpty=TRUE,TestNumc=TRUE,log=NULL) {
- |
-
| 38 | -- | - - | -
| 39 | -4x | -
- a = TRUE- |
-
| 40 | -- | - - | -
| 41 | -- |
- # Initialize logging if necessary- |
-
| 42 | -4x | -
- if (base::is.null(log)) {
- |
-
| 43 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 44 | -- |
- }- |
-
| 45 | -- | - - | -
| 46 | -4x | -
- if(!is.vector(vectIn) || is.list(vectIn)) {
- |
-
| 47 | -1x | -
- a=FALSE- |
-
| 48 | -1x | -
- log$error('Input must be a vector.')
- |
-
| 49 | -- |
- - |
-
| 50 | -- |
- }- |
-
| 51 | -3x | -
- else if (TestNumc == TRUE && !is.numeric(vectIn) && !is.logical(vectIn)) {
- |
-
| 52 | -1x | -
- a=FALSE- |
-
| 53 | -1x | -
- log$error('-------Input must be numeric or logical.')
- |
-
| 54 | -- |
- - |
-
| 55 | -- |
- }- |
-
| 56 | -2x | -
- else if (TestEmpty && length(vectIn) == 0) {
- |
-
| 57 | -1x | -
- a=FALSE- |
-
| 58 | -1x | -
- log$error('Input must not be empty.')
- |
-
| 59 | -- |
- - |
-
| 60 | -- |
- }- |
-
| 61 | -- | - - | -
| 62 | -4x | -
- return (a)- |
-
| 63 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read event data in json format- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read event data in json format into data frame. Converts timestamps to POSIX.- |
-
| 9 | -- |
- #' NOTE: The json records must have uniform format.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param NameFile String. Name (including relative or absolute path) of event json file.- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which no logger other than- |
-
| 14 | -- |
- #' standard R error messaging will be used.- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @return A data frame of the data contained in the json file.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @references- |
-
| 19 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @keywords Currently none- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @examples- |
-
| 24 | -- |
- #' myEventData <- NEONprocIS.base::def.read.evnt.json(NameFile='/scratch/test/myFile.json')- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.log.init}}
- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @export- |
-
| 29 | -- | - - | -
| 30 | -- |
- # changelog and author contributions / copyrights- |
-
| 31 | -- |
- # Cove Sturtevant (2019-12-19)- |
-
| 32 | -- |
- # original creation- |
-
| 33 | -- |
- # Mija Choi (2022-04-12)- |
-
| 34 | -- |
- # added log initialization and modified to catch errors- |
-
| 35 | -- |
- ##############################################################################################- |
-
| 36 | -- |
- def.read.evnt.json <- function(NameFile,log=NULL){
- |
-
| 37 | -- |
- - |
-
| 38 | -- |
- # Initialize log if not input- |
-
| 39 | -3x | -
- if(base::is.null(log)){
- |
-
| 40 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 41 | -- |
- }- |
-
| 42 | -- |
- - |
-
| 43 | -3x | -
- listEvnt <- base::try(rjson::fromJSON(file=NameFile,simplify=TRUE)[[1]],silent=FALSE)- |
-
| 44 | -3x | -
- if(base::class(listEvnt) == 'try-error'){
- |
-
| 45 | -1x | -
- msg <- base::paste0('File ', NameFile,' is unreadable.')
- |
-
| 46 | -1x | -
- log$fatal(msg)- |
-
| 47 | -1x | -
- stop(msg)- |
-
| 48 | -- |
- }- |
-
| 49 | -- |
- - |
-
| 50 | -- |
- # Turn all the NULLs into NAs- |
-
| 51 | -2x | -
- listEvnt <- base::lapply(listEvnt,function(list){
- |
-
| 52 | -2x | -
- base::lapply(list,function(valu){
- |
-
| 53 | -19x | -
- if(base::is.null(valu) || base::length(valu)==0){
- |
-
| 54 | -2x | -
- return(NA)- |
-
| 55 | -- |
- } else {
- |
-
| 56 | -17x | -
- return(valu)- |
-
| 57 | -- |
- }- |
-
| 58 | -- |
- })- |
-
| 59 | -- |
- })- |
-
| 60 | -- |
- - |
-
| 61 | -2x | -
- listEvnt <- base::lapply(listEvnt,base::as.data.frame,stringsAsFactors=FALSE)- |
-
| 62 | -2x | -
- evnt <- base::do.call(base::rbind,listEvnt)- |
-
| 63 | -- | - - | -
| 64 | -- |
- # Assign timestamps to POSIXct- |
-
| 65 | -2x | -
- evnt$timestamp <- base::strptime(evnt$timestamp,format='%Y-%d-%mT%H:%M:%OSZ',tz='GMT')- |
-
| 66 | -- |
- - |
-
| 67 | -1x | -
- return(evnt)- |
-
| 68 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Map data to an output avro schema- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Rearrange and/or create dummy columns in a data frame to match the column- |
-
| 9 | -- |
- #' order of an output avro schema. Optionally convert data type to match output schema.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Data frame with named columns.- |
-
| 12 | -- |
- #' @param schm json string of the output schema- |
-
| 13 | -- |
- #' @param ConvType Logical TRUE to attempt to convert the data type to that indicated in the json- |
-
| 14 | -- |
- #' schema. FALSE to attempt no type conversion. Default is FALSE. Note: POSIX conversion to- |
-
| 15 | -- |
- #' numeric will result in seconds since epoc 1970-01-01 00:00:00.- |
-
| 16 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 17 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @return A data frame that (hopefully) matches the output schema- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @references Currently none- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @keywords Currently none- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @examples- |
-
| 26 | -- |
- #' NEONprocIS.base::def.data.mapp.schma.avro(- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @seealso Currently none- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @export- |
-
| 31 | -- | - - | -
| 32 | -- |
- # changelog and author contributions / copyrights- |
-
| 33 | -- |
- # Cove Sturtevant (2020-02-20)- |
-
| 34 | -- |
- # original creation- |
-
| 35 | -- |
- ##############################################################################################- |
-
| 36 | -- |
- def.data.mapp.schm.avro <- function(data,schm,ConvType=FALSE,log=NULL){
- |
-
| 37 | -- |
- # initialize logging if necessary- |
-
| 38 | -3x | -
- if (base::is.null(log)) {
- |
-
| 39 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 40 | -- |
- }- |
-
| 41 | -- |
- - |
-
| 42 | -- |
- # Parse the schema to a list- |
-
| 43 | -3x | -
- schmList <- rjson::fromJSON(json_str=schm,simplify=FALSE)- |
-
| 44 | -- |
- - |
-
| 45 | -- |
- # Get the field names- |
-
| 46 | -3x | -
- nameVarOut <- base::unlist(base::lapply(schmList$fields,FUN=function(idxFld){idxFld$name}))
- |
-
| 47 | -- |
- - |
-
| 48 | -- |
- # Data columns may be missing and/or out of order. Add dummy columns for those that we're missing- |
-
| 49 | -3x | -
- nameVarAdd <- nameVarOut[!(nameVarOut %in% base::names(data))]- |
-
| 50 | -3x | -
- numData <- base::nrow(data)- |
-
| 51 | -3x | -
- for(idxVarAdd in nameVarAdd){
- |
-
| 52 | -3x | -
- data[[idxVarAdd]] <- base::rep(x=base::as.character(NA),times=numData)- |
-
| 53 | -- |
- }- |
-
| 54 | -- |
- # Rearrange to the original columns order & get rid of variables not in the schema- |
-
| 55 | -3x | -
- data <- data[,nameVarOut]- |
-
| 56 | -- |
- - |
-
| 57 | -3x | -
- if(ConvType == TRUE){
- |
-
| 58 | -- |
- # Assign the data type for each column from the schema- |
-
| 59 | -1x | -
- for(idxVar in base::seq_len(base::length(nameVarOut))){
- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # type indicated by schema- |
-
| 62 | -4x | -
- typeIdx <- base::unlist(schmList$fields[[idxVar]]$type)- |
-
| 63 | -- |
- - |
-
| 64 | -- |
- # Assign R class from schema-indicated data type- |
-
| 65 | -4x | -
- if(base::sum(typeIdx == "string") > 0){
- |
-
| 66 | -1x | -
- base::class(data[[idxVar]]) <- "character"- |
-
| 67 | -3x | -
- } else if (base::sum(typeIdx == "boolean") > 0){
- |
-
| 68 | -! | -
- base::class(data[[idxVar]]) <- "logical"- |
-
| 69 | -3x | -
- } else if (base::sum(typeIdx %in% c("int","long")) > 0){
- |
-
| 70 | -1x | -
- base::class(data[[idxVar]]) <- "integer"- |
-
| 71 | -2x | -
- } else if (base::sum(typeIdx %in% c("float","double")) > 0){
- |
-
| 72 | -1x | -
- base::class(data[[idxVar]]) <- "numeric"- |
-
| 73 | -- |
- }- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- }- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -3x | -
- return(data)- |
-
| 80 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read AVRO file (development library)- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in AVRO file. Uses a super developmental version of the library. The- |
-
| 9 | -- |
- #' requisite dependent libraries must be installed on the host system.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param NameFile String. Name (including relative or absolute path) of AVRO file.- |
-
| 12 | -- |
- #' @param NameLib String. Name (including relative or absolute path) of AVRO library.- |
-
| 13 | -- | - - | -
| 14 | -- |
- #' @return A data frame of the data contained in the AVRO file. The schema is included in attribute 'schema'- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @references- |
-
| 17 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @keywords Currently none- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @examples- |
-
| 22 | -- |
- #' myData <- NEONprocIS.base::def.read.avro.deve(NameFile='/scratch/test/myFile.avro',NameLib='/ravro.so')- |
-
| 23 | -- |
- #' attr(myData,'schema') # Returns the schema- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @seealso Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @export- |
-
| 28 | -- | - - | -
| 29 | -- |
- # changelog and author contributions / copyrights- |
-
| 30 | -- |
- # Cove Sturtevant (2019-03-13)- |
-
| 31 | -- |
- # original creation- |
-
| 32 | -- |
- # Cove Sturtevant (2019-09-30)- |
-
| 33 | -- |
- # assign R classes to empty data frames if they are NULL- |
-
| 34 | -- |
- # Cove Sturtevant (2019-10-09)- |
-
| 35 | -- |
- # generalized the conversion to POSIX for variables of type "timestamp-millis"- |
-
| 36 | -- |
- ##############################################################################################- |
-
| 37 | -- |
- def.read.avro.deve <- function(NameFile,- |
-
| 38 | -- |
- NameLib='ravro.so',- |
-
| 39 | -- |
- log=NULL- |
-
| 40 | -- |
- ){
- |
-
| 41 | -- |
- # initialize logging if necessary- |
-
| 42 | -7x | -
- if (base::is.null(log)) {
- |
-
| 43 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 44 | -- |
- }- |
-
| 45 | -- |
- - |
-
| 46 | -7x | -
- if(base::length(NameFile) > 1){
- |
-
| 47 | -1x | -
- NameFile <- NameFile[1]- |
-
| 48 | -1x | -
- log$warn(base::paste0('More than one data file was input. Using only the first: ',NameFile))
- |
-
| 49 | -- |
- }- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- - |
-
| 52 | -- |
- # Load the library- |
-
| 53 | -7x | -
- base::dyn.load(NameLib)- |
-
| 54 | -- |
- - |
-
| 55 | -- |
- # Read the data.- |
-
| 56 | -- |
- # Note: The package argument is needed to include this as a function in the NEONprocIS.base package- |
-
| 57 | -5x | -
- rpt <- base::.Call('readavro',NameFile,PACKAGE='ravro')
- |
-
| 58 | -- |
- - |
-
| 59 | -- |
- # If any of the column classes are NULL, read the data type from the schema and assign them- |
-
| 60 | -5x | -
- typeNull <- base::unlist(base::lapply(X=rpt,FUN=function(var){base::sum(base::class(var)=="NULL")==1}))
- |
-
| 61 | -- |
- - |
-
| 62 | -- |
- # Parse the schema to a list- |
-
| 63 | -5x | -
- Schm <- rjson::fromJSON(json_str=base::attr(rpt,"schema"),simplify=FALSE)- |
-
| 64 | -- |
- - |
-
| 65 | -- |
- # Assign the data type for each column from the schema- |
-
| 66 | -5x | -
- for(idxVarNull in base::names(typeNull)[typeNull]){
- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Which schema field pertains to this column- |
-
| 69 | -! | -
- idxSchm <- base::which(base::unlist(base::lapply(Schm$fields,FUN=function(idx){idx$name})) == idxVarNull)
- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # type indicated by schema- |
-
| 72 | -! | -
- typeIdx <- base::unlist(Schm$fields[[idxSchm]]$type)- |
-
| 73 | -- |
- - |
-
| 74 | -- |
- # Assign R class from schema-indicated data type- |
-
| 75 | -! | -
- if(base::sum(typeIdx == "string") > 0){
- |
-
| 76 | -! | -
- base::class(rpt[[idxVarNull]]) <- "character"- |
-
| 77 | -! | -
- } else if (base::sum(typeIdx == "boolean") > 0){
- |
-
| 78 | -! | -
- base::class(rpt[[idxVarNull]]) <- "logical"- |
-
| 79 | -! | -
- } else if (base::sum(typeIdx %in% c("int","long")) > 0){
- |
-
| 80 | -! | -
- base::class(rpt[[idxVarNull]]) <- "integer"- |
-
| 81 | -! | -
- } else if (base::sum(typeIdx %in% c("float","double")) > 0){
- |
-
| 82 | -! | -
- base::class(rpt[[idxVarNull]]) <- "numeric"- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- }- |
-
| 86 | -- |
- - |
-
| 87 | -- |
- # Assign timestamps to POSIXct- |
-
| 88 | -5x | -
- for(idxVar in base::names(rpt)){
- |
-
| 89 | -- |
- - |
-
| 90 | -- |
- # Which schema field pertains to this column- |
-
| 91 | -18x | -
- idxSchm <- base::which(base::unlist(base::lapply(Schm$fields,FUN=function(idx){idx$name})) == idxVar)
- |
-
| 92 | -- |
- - |
-
| 93 | -- |
- # type indicated by schema- |
-
| 94 | -18x | -
- typeIdx <- base::unlist(Schm$fields[[idxSchm]]$type)- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- # Assign R class from schema-indicated data type- |
-
| 97 | -18x | -
- if(base::sum(typeIdx == "timestamp-millis") > 0){
- |
-
| 98 | -! | -
- rpt[[idxVar]] <- base::as.POSIXct(x=rpt[[idxVar]]/1000, tz = "GMT", origin=as.POSIXct('1970-01-01',tz = "GMT"))
- |
-
| 99 | -- |
- }- |
-
| 100 | -- |
- - |
-
| 101 | -- |
- }- |
-
| 102 | -- |
- - |
-
| 103 | -5x | -
- return(rpt)- |
-
| 104 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Write AVRO file (development library)- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Write AVRO file from data frame. Uses a super developmental version of the library. The- |
-
| 9 | -- |
- #' requisite dependent libraries must be installed on the host system.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Data frame. Data to write to file.- |
-
| 12 | -- |
- #' @param NameFile String. Name (including relative or absolute path) of AVRO file.- |
-
| 13 | -- |
- #' @param NameSchm String. Optional. Schema name.- |
-
| 14 | -- |
- #' @param NameSpceSchm String. Optional. Schema namepace.- |
-
| 15 | -- |
- #' @param Schm String. Optional. Json formatted string of the AVRO file schema. Example:\cr- |
-
| 16 | -- |
- #' "{\"type\" : \"record\",\"name\" : \"ST\",\"namespace\" : \"org.neonscience.schema.device\",\"fields\" : [ {\"name\" :\"readout_time\",\"type\" : {\"type\" : \"long\",\"logicalType\" : \"timestamp-millis\"},\"doc\" : \"Timestamp of readout expressed in milliseconds since epoch\"}, {\"name\" : \"soilPRTResistance\",\"type\" : [ \"null\", \"float\" ],\"doc\" : \"DPID: DP0.00041.001 TermID: 1728 Units: ohm Description: Soil Temperature, Level 0\",\"default\" : null} ],\"__fastavro_parsed\" : true}"\cr
- |
-
| 17 | -- |
- #' Defaults to NULL, at which point the schema will be constructed using a different input or the data frame- |
-
| 18 | -- |
- #' @param NameFileSchm String. Optional. A filename (include relative or aboslute path) of an avro- |
-
| 19 | -- |
- #' schema file (.avsc format). Defaults to NULL, at which point the schema will be constructed using a different- |
-
| 20 | -- |
- #' input or from the data frame- |
-
| 21 | -- |
- #' @param NameLib String. Name (including relative or absolute path) of AVRO library. Defaults to ./ravro.so.- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @return Numeric. 0 = successful write.- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @references- |
-
| 26 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @keywords Currently none- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @examples Currently none- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.avro.deve}
- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @export- |
-
| 35 | -- | - - | -
| 36 | -- |
- # changelog and author contributions / copyrights- |
-
| 37 | -- |
- # Cove Sturtevant (2019-03-21)- |
-
| 38 | -- |
- # original creation- |
-
| 39 | -- |
- # Cove Sturtevant (2019-04-15)- |
-
| 40 | -- |
- # adjusting for new ravro library that auto-creates schema from data frame- |
-
| 41 | -- |
- # Cove Sturtevant (2019-04-24)- |
-
| 42 | -- |
- # adjusting for new ravro library that writes class character- |
-
| 43 | -- |
- # Cove Sturtevant (2019-06-17)- |
-
| 44 | -- |
- # adding option to read output schema from file.- |
-
| 45 | -- |
- # Fix bug in call to write with schema.- |
-
| 46 | -- |
- # Cove Sturtevant (2019-10-09)- |
-
| 47 | -- |
- # fix bug not allowing conversion of multiple POSIX variables to numeric- |
-
| 48 | -- |
- ##############################################################################################- |
-
| 49 | -- |
- def.wrte.avro.deve <- function(data,- |
-
| 50 | -- |
- NameFile,- |
-
| 51 | -- |
- NameSchm=NULL,- |
-
| 52 | -- |
- NameSpceSchm=NULL,- |
-
| 53 | -- |
- Schm=NULL,- |
-
| 54 | -- |
- NameFileSchm=NULL,- |
-
| 55 | -- |
- NameLib='ravro.so'- |
-
| 56 | -- |
- ){
- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # Load the library- |
-
| 59 | -4x | -
- base::dyn.load(NameLib)- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # Are any variables in POSIX format? Convert to milliseconds since epoc 1970-01-01 00:00:00- |
-
| 62 | -4x | -
- clssVar <- base::lapply(X=data,FUN=base::class)- |
-
| 63 | -4x | -
- idxTime <- base::unlist(base::lapply(X=clssVar,FUN=function(idxClss){base::sum(base::grepl(pattern='POSIX',x=idxClss))>0}))
- |
-
| 64 | -4x | -
- data[,idxTime] <- base::as.data.frame(base::lapply(base::subset(data,select=idxTime),base::as.numeric))*1000 # Convert- |
-
| 65 | -- |
- - |
-
| 66 | -- |
- # Are there any variables as factor?- |
-
| 67 | -4x | -
- if(base::sum(c('factor') %in% clssVar) > 0){
- |
-
| 68 | -! | -
- stop('Cannot write data of class factor.')
- |
-
| 69 | -- |
- }- |
-
| 70 | -- | - - | -
| 71 | -- |
- # Assign schema name and namespace- |
-
| 72 | -4x | -
- if(!base::is.null(NameSchm)){
- |
-
| 73 | -1x | -
- base::attr(data, "avroname") <- "myschemaname"- |
-
| 74 | -- |
- }- |
-
| 75 | -4x | -
- if(!base::is.null(NameSpceSchm)){
- |
-
| 76 | -1x | -
- base::attr(data, "avronamespace") <- "myschemanamespace"- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # Write the data.- |
-
| 80 | -- |
- # Note: The PACKAGE argument is needed to include this as a function in the NEONprocIS.base package- |
-
| 81 | -4x | -
- if(base::is.null(Schm) && base::is.null(NameFileSchm)){
- |
-
| 82 | -- |
- # Schema to be constructed from data frame- |
-
| 83 | -2x | -
- rpt <- base::.Call('writeavro',data,NameFile,PACKAGE='ravro')
- |
-
| 84 | -- |
- } else {
- |
-
| 85 | -- |
- # Schema specified in inputs- |
-
| 86 | -- |
- - |
-
| 87 | -- |
- # Read in schema file- |
-
| 88 | -2x | -
- if(!base::is.null(NameFileSchm)){
- |
-
| 89 | -2x | -
- con <- base::file(NameFileSchm,open='r')- |
-
| 90 | -2x | -
- Schm <- base::paste0(base::readLines(con),collapse='')- |
-
| 91 | -2x | -
- base::close(con)- |
-
| 92 | -- |
- }- |
-
| 93 | -- |
- - |
-
| 94 | -2x | -
- rpt <- base::.Call('writeavro_withschema',data,Schm,NameFile,PACKAGE='ravro')
- |
-
| 95 | -- |
- }- |
-
| 96 | -- |
- - |
-
| 97 | -4x | -
- return(rpt)- |
-
| 98 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Create Parquet schema auto-detected from data frame- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Create an arrow schema object auto-detected from data frame- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param df Data frame- |
-
| 11 | -- |
- #' @param log Optional. A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 12 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 13 | -- |
- #' created for use within this function.- |
-
| 14 | -- |
- #'- |
-
| 15 | -- |
- #' @return An Apache Arrow Schema object for the input data frame- |
-
| 16 | -- | - - | -
| 17 | -- |
- #' @references- |
-
| 18 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @keywords Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @examples Currently none- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @seealso \link[arrow]{data-type}
- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @export- |
-
| 27 | -- | - - | -
| 28 | -- |
- # changelog and author contributions / copyrights- |
-
| 29 | -- |
- # Cove Sturtevant (2023-08-14)- |
-
| 30 | -- |
- # original creation- |
-
| 31 | -- |
- ##############################################################################################- |
-
| 32 | -- |
- def.schm.parq.from.df <- function(df,- |
-
| 33 | -- |
- log=NULL- |
-
| 34 | -- |
- ){
- |
-
| 35 | -- |
- # initialize logging if necessary- |
-
| 36 | -2x | -
- if (base::is.null(log)) {
- |
-
| 37 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 38 | -- |
- }- |
-
| 39 | -- |
- - |
-
| 40 | -- |
- # Parse- |
-
| 41 | -2x | -
- typeVar <- base::lapply(df,base::class)- |
-
| 42 | -2x | -
- numVar <- base::length(typeVar)- |
-
| 43 | -2x | -
- nameVar <- base::names(df)- |
-
| 44 | -- |
- - |
-
| 45 | -- |
- # Create each field in the schema- |
-
| 46 | -- |
- #Arrow timestamps are stored as a 64-bit integer with column metadata to associate a time unit (e.g. milliseconds, microseconds, or nanoseconds), and an optional time zone.- |
-
| 47 | -2x | -
- fldSchm <- base::vector(numVar,mode='list') # Initialize list of schema fields- |
-
| 48 | -2x | -
- for(idx in base::seq_len(numVar)){
- |
-
| 49 | -- |
- - |
-
| 50 | -4x | -
- nameField <- nameVar[idx]- |
-
| 51 | -4x | -
- typeData <- typeVar[idx]- |
-
| 52 | -- | - - | -
| 53 | -- |
- # See documentation on arrow::data-type- |
-
| 54 | -4x | -
- if (base::any(base::grepl('POSIX', typeData) | grepl('Date',typeData))) {
- |
-
| 55 | -! | -
- tz <- base::attr(df[[nameField]],'tzone')- |
-
| 56 | -! | -
- if(is.null(tz)){
- |
-
| 57 | -! | -
- tz=""- |
-
| 58 | -- |
- }- |
-
| 59 | -! | -
- typeArrw <- arrow::timestamp(unit = "ms", timezone = tz)- |
-
| 60 | -- | - - | -
| 61 | -4x | -
- } else if (base::any(typeData == 'numeric')) {
- |
-
| 62 | -2x | -
- typeArrw <- arrow::float()- |
-
| 63 | -- |
- - |
-
| 64 | -2x | -
- } else if (base::any(typeData == 'integer')) {
- |
-
| 65 | -! | -
- typeArrw <- arrow::int32()- |
-
| 66 | -- |
- - |
-
| 67 | -2x | -
- } else if (base::any(typeData == 'character')) {
- |
-
| 68 | -2x | -
- typeArrw <- arrow::string()- |
-
| 69 | -- |
- - |
-
| 70 | -! | -
- } else if (base::any(typeData == 'logical')) {
- |
-
| 71 | -! | -
- typeArrw <- arrow::boolean()- |
-
| 72 | -- | - - | -
| 73 | -- |
- } else {
- |
-
| 74 | -! | -
- typeArrw <- arrow::null()- |
-
| 75 | -! | -
- log$warn(base::paste0('Data type(s) [',base::paste0(typeData,collapse=','),'] not recognized for field name [',nameField,']. Setting parquet schema type to null, which will likely result in NA data.'))
- |
-
| 76 | -- |
- }- |
-
| 77 | -- |
- - |
-
| 78 | -- |
- # Place in the list- |
-
| 79 | -- |
- # if (base::any(typeData == 'null')){
- |
-
| 80 | -4x | -
- nullable = TRUE- |
-
| 81 | -- |
- # } else {
- |
-
| 82 | -- |
- # nullable = FALSE- |
-
| 83 | -- |
- # }- |
-
| 84 | -4x | -
- fldSchm[[idx]] <- arrow::field(nameField, typeArrw, nullable = nullable)- |
-
| 85 | -- |
- }- |
-
| 86 | -- |
- - |
-
| 87 | -- |
- # Create schema- |
-
| 88 | -- |
- # Example- |
-
| 89 | -- |
- # arrow::schema(- |
-
| 90 | -- |
- # arrow::field("c", arrow::bool(),nullable = TRUE),
- |
-
| 91 | -- |
- # )- |
-
| 92 | -2x | -
- schm <- base::do.call(arrow::schema, fldSchm)- |
-
| 93 | -- | - - | -
| 94 | -- |
- - |
-
| 95 | -2x | -
- return(schm)- |
-
| 96 | -- |
- }- |
-
| 1 | -- |
- ###################################################################################################- |
-
| 2 | -- |
- #' @title Validate data frame not empty or invalid- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Mija Choi \email{choim@battelleecology.org}
- |
-
| 6 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 7 | -- | - - | -
| 8 | -- |
- #' @description- |
-
| 9 | -- |
- #' Validate a data frame to check it is empty or has invalid values.- |
-
| 10 | -- |
- #' Returns True if not empty AND has vaild values. FALSE otherwise.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param dfIn Input data frame to be validated- |
-
| 13 | -- |
- #' @param TestNa Boolean where TRUE results in testing for any NA values (resulting in FALSE output). Defaults to FALSE.- |
-
| 14 | -- |
- #' @param TestNumc Boolean where TRUE results in testing for any non-numeric values (resulting in FALSE output). Defaults to FALSE.- |
-
| 15 | -- |
- #' @param TestNameCol A character vector of minimum expected column names in dfIn. Defaults to zero-length character (none expected).- |
-
| 16 | -- |
- #' @param TestEmpty Boolean where TRUE results in testing for at least 1 row in \code{dfIn}. Defaults to TRUE.
- |
-
| 17 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 18 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 19 | -- |
- #' created and used within the function.- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @return Boolean. True if the input data frame is not empty AND does not have invalid values. FALSE otherwise. \cr- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @references Currently none- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @keywords Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @examples Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 30 | -- |
- #'- |
-
| 31 | -- |
- #' @export- |
-
| 32 | -- | - - | -
| 33 | -- |
- # changelog and author contributions / copyrights- |
-
| 34 | -- |
- # Mija Choi (2020-01-07)- |
-
| 35 | -- |
- # original creation- |
-
| 36 | -- |
- # Cove Sturtevant (2020-02-03)- |
-
| 37 | -- |
- # added options for testing non-numeric values, NA values, and expected columns- |
-
| 38 | -- |
- # added logging of failures- |
-
| 39 | -- |
- # Cove Sturtevant (2020-09-16)- |
-
| 40 | -- |
- # add test for non-empty data frame (at least 1 row)- |
-
| 41 | -- |
- ##############################################################################################- |
-
| 42 | -- | - - | -
| 43 | -- |
- def.validate.dataframe <-- |
-
| 44 | -- |
- function(dfIn,- |
-
| 45 | -- |
- TestNa = FALSE,- |
-
| 46 | -- |
- TestNumc = FALSE,- |
-
| 47 | -- |
- TestNameCol = base::character(0),- |
-
| 48 | -- |
- TestEmpty=TRUE,- |
-
| 49 | -- |
- log = NULL) {
- |
-
| 50 | -- |
- # Initialize logging if necessary- |
-
| 51 | -19x | -
- if (base::is.null(log)) {
- |
-
| 52 | -6x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 53 | -- |
- }- |
-
| 54 | -19x | -
- msg <- NULL- |
-
| 55 | -- |
- - |
-
| 56 | -19x | -
- b <- TRUE- |
-
| 57 | -- |
- - |
-
| 58 | -19x | -
- if (!is.data.frame(dfIn)) {
- |
-
| 59 | -1x | -
- b <- FALSE- |
-
| 60 | -1x | -
- log$error('Input is not a data frame.')
- |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- - |
-
| 63 | -18x | -
- else if (TestEmpty == TRUE && nrow(dfIn) == 0) {
- |
-
| 64 | -1x | -
- b <- FALSE- |
-
| 65 | -1x | -
- log$error('Data frame is empty (zero rows).')
- |
-
| 66 | -- |
- - |
-
| 67 | -- |
- }- |
-
| 68 | -- |
- - |
-
| 69 | -17x | -
- else if (TestNa == TRUE && any(is.na(dfIn))) {
- |
-
| 70 | -1x | -
- b <- FALSE- |
-
| 71 | -1x | -
- log$error('No NA values are allowed in the data frame.')
- |
-
| 72 | -- |
- }- |
-
| 73 | -- |
- - |
-
| 74 | -16x | -
- else if (TestNumc == TRUE &&- |
-
| 75 | -16x | -
- any(!unlist(lapply(dfIn, is.numeric)))) {
- |
-
| 76 | -1x | -
- b <- FALSE- |
-
| 77 | -1x | -
- log$error('Data frame is required to be numeric.')
- |
-
| 78 | -- |
- }- |
-
| 79 | -- |
- - |
-
| 80 | -15x | -
- else if (!base::all(TestNameCol %in% base::names(dfIn))){
- |
-
| 81 | -2x | -
- b <- FALSE- |
-
| 82 | -2x | -
- log$error(base::paste0('Columns ', base::paste0(TestNameCol[!(TestNameCol %in% base::names(dfIn))],collapse=','),' are missing from the data frame.'))
- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -19x | -
- return (b)- |
-
| 86 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Convert data types in data frame to be compatible with parquet or avro schema data types- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Convert data types in data frame to match parquet or avro schema types.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param data Data frame of data to be converted.- |
-
| 11 | -- |
- #' @param type A data frame of: \cr- |
-
| 12 | -- |
- #' \code{name} Character. Name of data column
- |
-
| 13 | -- |
- #' \code{type} Character. Data type. There may be multiple types, delimited by pipes (|)
- |
-
| 14 | -- |
- #' \code{nullable} Boolean. Whether the field values are allowed to be null or NA
- |
-
| 15 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 16 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @return The input data frame with data types converted as specified- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @references- |
-
| 21 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @keywords Currently none- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @examples- |
-
| 26 | -- |
- #' data <- data.frame(x=c(1,2,3),y=c('one','two','three'),stringsAsFactors=FALSE)
- |
-
| 27 | -- |
- #' type <- data.frame(name=c('x'),type=c('string|utf8'),nullable=TRUE,stringsAsFactors=FALSE)
- |
-
| 28 | -- |
- #' dataOut <- NEONprocIS.base::def.data.conv.type.parq(data=data,type=type)- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @seealso \link[NEONprocIS.base]{def.write.parq}
- |
-
| 31 | -- |
- #' @seealso \link[arrow]{data-type}
- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @export- |
-
| 34 | -- | - - | -
| 35 | -- |
- # changelog and author contributions / copyrights- |
-
| 36 | -- |
- # Cove Sturtevant (2019-04-16)- |
-
| 37 | -- |
- # original creation- |
-
| 38 | -- |
- # Cove Sturtevant (2023-02-21)- |
-
| 39 | -- |
- # refined arrow data types- |
-
| 40 | -- |
- # Cove Sturtevant (2024-03-20)- |
-
| 41 | -- |
- # add error checking for null values in non-nullable fields- |
-
| 42 | -- |
- # Cove Sturtevant (2025-05-07)- |
-
| 43 | -- |
- # Do not attempt to convert lists- |
-
| 44 | -- |
- ##############################################################################################- |
-
| 45 | -- |
- def.data.conv.type.parq <- function(data,- |
-
| 46 | -- |
- type,- |
-
| 47 | -- |
- log=NULL- |
-
| 48 | -- |
- ){
- |
-
| 49 | -- |
- # initialize logging if necessary- |
-
| 50 | -16x | -
- if (base::is.null(log)) {
- |
-
| 51 | -7x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 52 | -- |
- }- |
-
| 53 | -- |
- - |
-
| 54 | -- |
- # Pull the variable names in data- |
-
| 55 | -16x | -
- nameVar <- base::names(data)- |
-
| 56 | -- |
- - |
-
| 57 | -- |
- # Assign the data type for each column- |
-
| 58 | -16x | -
- for(idx in base::seq_len(base::nrow(type))){
- |
-
| 59 | -- |
- - |
-
| 60 | -- |
- # Get column name and type- |
-
| 61 | -35x | -
- nameIdx <- type$name[idx]- |
-
| 62 | -35x | -
- typeIdx <- strsplit(type$type[idx],'[|]')[[1]]- |
-
| 63 | -35x | -
- nullIdx <- type$nullable[idx]- |
-
| 64 | -- |
- - |
-
| 65 | -35x | -
- if(!(nameIdx %in% nameVar)){
- |
-
| 66 | -1x | -
- log$warn(base::paste0('Variable: ', nameIdx, ' not found in input data. No type conversion will be performed for this variable.'))
- |
-
| 67 | -1x | -
- next- |
-
| 68 | -- |
- }- |
-
| 69 | -- |
- - |
-
| 70 | -- |
- # Assign R class from schema-indicated data type- |
-
| 71 | -34x | -
- if(base::any(base::grepl('time',typeIdx)) || base::any(base::grepl('date',typeIdx))){
- |
-
| 72 | -- |
- # Convert to POSIXct. Parquet writer handles this well.- |
-
| 73 | -7x | -
- data[[nameIdx]] <- base::as.POSIXct(data[[nameIdx]],tz='GMT')- |
-
| 74 | -- |
- - |
-
| 75 | -27x | -
- } else if(base::any(base::grepl('dictionary<values=string',typeIdx))){
- |
-
| 76 | -- |
- # Use as.character rather than class(..) <- 'character'. Converts factors to character without factors as attributes.- |
-
| 77 | -1x | -
- data[[nameIdx]] <- base::as.factor(data[[nameIdx]])- |
-
| 78 | -- |
- - |
-
| 79 | -26x | -
- } else if(base::any(typeIdx %in% c('string','utf8','large_utf8','character'))){
- |
-
| 80 | -- |
- # Use as.character rather than class(..) <- 'character'. Converts factors to character without factors as attributes.- |
-
| 81 | -13x | -
- data[[nameIdx]] <- base::as.character(data[[nameIdx]])- |
-
| 82 | -- |
- - |
-
| 83 | -13x | -
- } else if (base::any(typeIdx %in% c('bool','boolean','logical'))){
- |
-
| 84 | -1x | -
- base::class(data[[nameIdx]]) <- "logical"- |
-
| 85 | -- |
- - |
-
| 86 | -12x | -
- } else if (base::any(base::grepl('int',typeIdx)) || base::any(typeIdx %in% c("long","short"))){
- |
-
| 87 | -2x | -
- base::class(data[[nameIdx]]) <- "integer"- |
-
| 88 | -- |
- - |
-
| 89 | -10x | -
- } else if (base::any(base::grepl('float',typeIdx) & !substr(typeIdx,1,5) == 'list<') || base::any(typeIdx %in% c("numeric","decimal"))){
- |
-
| 90 | -7x | -
- base::class(data[[nameIdx]]) <- "numeric"- |
-
| 91 | -- |
- - |
-
| 92 | -3x | -
- } else if ("double" %in% typeIdx){
- |
-
| 93 | -2x | -
- base::class(data[[nameIdx]]) <- "double"- |
-
| 94 | -- |
- - |
-
| 95 | -- |
- } else {
- |
-
| 96 | -1x | -
- log$warn(base::paste0("Don't know what to do with data type: ",typeIdx,' intended for variable: ',nameIdx,'. No type conversion will be attempted.'))
- |
-
| 97 | -- |
- }- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- # Check for null / NA values for non-nullable fields- |
-
| 100 | -34x | -
- if(nullIdx == FALSE && base::any(base::is.na(data[[nameIdx]]))){
- |
-
| 101 | -! | -
- log$error(base::paste0('Field ',nameIdx,' has missing values but is indicated to be non-nullable in the schema. Check data and/or schema.'))
- |
-
| 102 | -! | -
- stop()- |
-
| 103 | -- |
- }- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- }- |
-
| 106 | -- |
- - |
-
| 107 | -16x | -
- return(data)- |
-
| 108 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Determine input directories based on expected subdirectories- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Determine the input directories (one or more) considered to be individual- |
-
| 9 | -- |
- #' datums based on matching the names of child directories.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param DirBgn String. Directory path considered to be zero or more parents above the input directories.- |
-
| 12 | -- |
- #' @param nameDirSub String vector. The exact names of expected direct child directories (does not need to- |
-
| 13 | -- |
- #' be a complete list of the subdirectories, but all must be found in the input directory for it to be- |
-
| 14 | -- |
- #' returned in the output).- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @return A character vector of input directories (datums)- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @references Currently none- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @keywords Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @examples Currently none- |
-
| 23 | -- |
- #' def.dir.in(DirBgn='/scratch/pfs/proc_group/prt/27134/2019/01/01',nameDirSub=c('data','calibration'))
- |
-
| 24 | -- | - - | -
| 25 | -- | - - | -
| 26 | -- |
- #' @seealso Currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @export- |
-
| 29 | -- | - - | -
| 30 | -- |
- # changelog and author contributions / copyrights- |
-
| 31 | -- |
- # Cove Sturtevant (2019-04-30)- |
-
| 32 | -- |
- # original creation- |
-
| 33 | -- |
- # Cove Sturtevant (2019-10-01)- |
-
| 34 | -- |
- # add catch for duplicate nameDirSub- |
-
| 35 | -- |
- # Cove Sturtevant (2010-01-30)- |
-
| 36 | -- |
- # add log output- |
-
| 37 | -- |
- ##############################################################################################- |
-
| 38 | -- |
- def.dir.in <- function(DirBgn,nameDirSub,log=NULL){
- |
-
| 39 | -- |
- - |
-
| 40 | -- |
- # Initialize log if not input- |
-
| 41 | -3x | -
- if(base::is.null(log)){
- |
-
| 42 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 43 | -- |
- }- |
-
| 44 | -- |
- - |
-
| 45 | -- |
- # Get rid of duplicates- |
-
| 46 | -3x | -
- nameDirSub <- base::unique(nameDirSub)- |
-
| 47 | -- |
- - |
-
| 48 | -- |
- # Get a recursive directory listing- |
-
| 49 | -3x | -
- dirAll <- base::list.dirs(path=DirBgn,full.names = TRUE, recursive = TRUE)- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # Separate the directories- |
-
| 52 | -3x | -
- dirAllSplt <- base::strsplit(dirAll,'/',fixed=TRUE)- |
-
| 53 | -3x | -
- dirAllBgn <- base::unlist(base::lapply(dirAllSplt,FUN=function(idxDir){
- |
-
| 54 | -3x | -
- base::paste0(utils::head(x=idxDir,n=-1),collapse='/')}))- |
-
| 55 | -3x | -
- dirAllEnd <- base::unlist(base::lapply(dirAllSplt,utils::tail,n=1))- |
-
| 56 | -- |
- - |
-
| 57 | -- |
- # If there are no subdirectories expected in the datum directory, then each terminal directory is a datum- |
-
| 58 | -3x | -
- if(base::length(nameDirSub) == 0){
- |
-
| 59 | -- |
- # Find the ones that dont nest in anything else- |
-
| 60 | -1x | -
- setMtch <- base::unlist(- |
-
| 61 | -1x | -
- base::lapply(dirAllSplt,FUN=function(idxDirSplt){
- |
-
| 62 | -5x | -
- base::sum(- |
-
| 63 | -5x | -
- base::unlist(- |
-
| 64 | -5x | -
- base::lapply(dirAllSplt,FUN=function(idxDirAllSplt){
- |
-
| 65 | -25x | -
- base::all(- |
-
| 66 | -25x | -
- idxDirSplt %in% idxDirAllSplt- |
-
| 67 | -- |
- )- |
-
| 68 | -- |
- })- |
-
| 69 | -- |
- )- |
-
| 70 | -5x | -
- ) <= 1- |
-
| 71 | -- |
- })- |
-
| 72 | -- |
- )- |
-
| 73 | -1x | -
- DirIn <- base::unique(dirAll[setMtch])- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- } else {
- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- # Filter the list for directories that end with one of our subdirectories- |
-
| 78 | -2x | -
- setMtch <- dirAllEnd %in% nameDirSub- |
-
| 79 | -2x | -
- dirAll <- dirAll[setMtch]- |
-
| 80 | -2x | -
- dirAllBgn <- dirAllBgn[setMtch]- |
-
| 81 | -2x | -
- dirAllEnd <- dirAllEnd[setMtch]- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- # For each remaining directory, there must be a number of matching parent directories equaling- |
-
| 84 | -- |
- # the length of nameDirSub. If there is, then the parent directory is a datum- |
-
| 85 | -2x | -
- numDirMtch <- base::length(nameDirSub)- |
-
| 86 | -2x | -
- setMtch <- base::unlist(base::lapply(dirAllBgn,FUN=function(idxDir){
- |
-
| 87 | -4x | -
- base::sum(dirAllBgn==idxDir)==numDirMtch- |
-
| 88 | -- |
- }))- |
-
| 89 | -2x | -
- DirIn <- base::unique(dirAllBgn[setMtch])- |
-
| 90 | -- |
- - |
-
| 91 | -- |
- }- |
-
| 92 | -- |
- - |
-
| 93 | -- |
- # Log status- |
-
| 94 | -3x | -
- if(base::length(DirIn) == 0){
- |
-
| 95 | -1x | -
- log$warn(base::paste0('No datums found for processing in parent directory ',DirBgn))
- |
-
| 96 | -- |
- } else {
- |
-
| 97 | -2x | -
- log$info(base::paste0(base::length(DirIn),' datums found for processing.'))- |
-
| 98 | -- |
- }- |
-
| 99 | -- |
- - |
-
| 100 | -3x | -
- return(DirIn)- |
-
| 101 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Route datum errors to specified location- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Route datum paths that errored to a specified error directory.- |
-
| 9 | -- |
- #' The input path to the erroring datum will be created in the error directory.- |
-
| 10 | -- |
- #' Optionally, remove any partial output from the errored datum.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param err The error condition returned from a function call. For printing only. Defaults to NULL.- |
-
| 13 | -- |
- #' @param call.stack The call stack returned from e.g. base::sys.calls(). For printing only. Defaults to NULL.- |
-
| 14 | -- |
- #' @param DirDatm Character value. The input path to the datum, structured as follows:- |
-
| 15 | -- |
- #' #/pfs/BASE_REPO/#, where # indicates any number of parent and child directories- |
-
| 16 | -- |
- #' of any name, so long as they are not 'pfs'. Note that the path should terminate at- |
-
| 17 | -- |
- #' the directory containing all the data and metadata (nested in further subdirectories- |
-
| 18 | -- |
- #' as needed) considered to be one complete entity for processing.- |
-
| 19 | -- |
- #' For example:- |
-
| 20 | -- |
- #' DirDatm = /scratch/pfs/proc_group/prt/2019/01/01/27134- |
-
| 21 | -- |
- #' @param DirErrBase Character value. The path that will replace the #/pfs/BASE_REPO portion of DirDatm- |
-
| 22 | -- |
- #' @param RmvDataOut Logical. TRUE to remove any partial output for the datum from the output repo. NOTE:- |
-
| 23 | -- |
- #' Removing partial output only works if the output datum path matches the typical structure where- |
-
| 24 | -- |
- #' DirOutBase replaces the #/pfs/BASE_REPO portion of DirDatm, but otherwise is the same as DirDatm.- |
-
| 25 | -- |
- #' If this is not the case, set RmvDataOut to FALSE (which is the default).- |
-
| 26 | -- |
- #' @param DirOutBase Character value. The path that will replace the #/pfs/BASE_REPO portion of- |
-
| 27 | -- |
- #' DirIn when writing successful output for the datum.- |
-
| 28 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 29 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 30 | -- |
- #' created and used within the function.- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @return The action of creating the path structure to the datum within DirErrBase, having replaced- |
-
| 33 | -- |
- #' the #/pfs/BASE_REPO portion of DirDatm with DirErrBase. If RmvDataOut is set to true, any partial- |
-
| 34 | -- |
- #' output for DirDatm will be removed. The output directory is the same as DirDatm but with the- |
-
| 35 | -- |
- #' #/pfs/BASE_REPO portion of DirDatm replaced with DirOutBase.- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @references- |
-
| 38 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 39 | -- | - - | -
| 40 | -- |
- #' @keywords Currently none- |
-
| 41 | -- | - - | -
| 42 | -- |
- #' @examples- |
-
| 43 | -- |
- #' # Not run:- |
-
| 44 | -- |
- #' DirDatm <- '/scratch/pfs/proc_group/prt/2019/01/01/27134'- |
-
| 45 | -- |
- #' DirErrBase <- '/scratch/pfs/proc_group_output/errored_datums'- |
-
| 46 | -- |
- #' RmvDatmOut <- TRUE- |
-
| 47 | -- |
- #' DirOutBase <- '/scratch/pfs/proc_group_output'- |
-
| 48 | -- |
- #' tryCatch(- |
-
| 49 | -- |
- #' withCallingHandlers(- |
-
| 50 | -- |
- #' stop('error!'),
- |
-
| 51 | -- |
- #' error=function(err) {
- |
-
| 52 | -- |
- #' call.stack <- base::sys.calls() # is like a traceback within "withCallingHandlers"- |
-
| 53 | -- |
- #' def.err.datm(err=err,- |
-
| 54 | -- |
- #' call.stack=call.stack,- |
-
| 55 | -- |
- #' DirDatm=DirDatm,- |
-
| 56 | -- |
- #' DirErrBase=DirErrBase,- |
-
| 57 | -- |
- #' RmvDatmOut=RmvDatmOut,- |
-
| 58 | -- |
- #' DirOutBase=DirOutBase)- |
-
| 59 | -- |
- #' )- |
-
| 60 | -- |
- #' }- |
-
| 61 | -- |
- #' ),- |
-
| 62 | -- |
- #' error=function(err){print('I routed an error!')}
- |
-
| 63 | -- |
- #' )- |
-
| 64 | -- |
- #'- |
-
| 65 | -- | - - | -
| 66 | -- | - - | -
| 67 | -- |
- #' @seealso tryCatch- |
-
| 68 | -- | - - | -
| 69 | -- |
- #' @export- |
-
| 70 | -- | - - | -
| 71 | -- |
- # changelog and author contributions / copyrights- |
-
| 72 | -- |
- # Cove Sturtevant (2021-08-10)- |
-
| 73 | -- |
- # original creation- |
-
| 74 | -- |
- # Cove Sturtevant (2022-09-19)- |
-
| 75 | -- |
- # add zero-byte file to failed datum directory (required for Pachyderm 2.x)- |
-
| 76 | -- |
- ##############################################################################################- |
-
| 77 | -- |
- def.err.datm <- function(- |
-
| 78 | -- |
- err=NULL,- |
-
| 79 | -- |
- call.stack=NULL,- |
-
| 80 | -- |
- DirDatm,- |
-
| 81 | -- |
- DirErrBase,- |
-
| 82 | -- |
- RmvDatmOut=FALSE,- |
-
| 83 | -- |
- DirOutBase=NULL,- |
-
| 84 | -- |
- log=NULL){
- |
-
| 85 | -- | - - | -
| 86 | -- |
- # initialize logging if necessary- |
-
| 87 | -3x | -
- if (base::is.null(log)) {
- |
-
| 88 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 89 | -- |
- }- |
-
| 90 | -- |
- - |
-
| 91 | -3x | -
- log$error(err$message)- |
-
| 92 | -3x | -
- base::message('Error resulted from call to: ')
- |
-
| 93 | -3x | -
- base::print(err$call)- |
-
| 94 | -3x | -
- base::message('Call stack:')
- |
-
| 95 | -3x | -
- base::print(limitedLabels(call.stack))- |
-
| 96 | -- |
- - |
-
| 97 | -- |
- # Make sure the output directory is a character- |
-
| 98 | -3x | -
- if(base::length(DirErrBase) != 1 && !base::is.character(DirErrBase)){
- |
-
| 99 | -1x | -
- log$fatal(base::paste0('DirErrBase (',DirErrBase,') must be a character string.'))
- |
-
| 100 | -1x | -
- stop()- |
-
| 101 | -- |
- }- |
-
| 102 | -- |
- - |
-
| 103 | -- |
- # Tell the user about the error routing- |
-
| 104 | -2x | -
- log$info(- |
-
| 105 | -2x | -
- base::paste0(- |
-
| 106 | -2x | -
- 'Re-routing failed datum path ',- |
-
| 107 | -2x | -
- DirDatm,- |
-
| 108 | -2x | -
- ' to ',- |
-
| 109 | -2x | -
- DirErrBase- |
-
| 110 | -- |
- )- |
-
| 111 | -- |
- )- |
-
| 112 | -- | - - | -
| 113 | -- |
- # Parse the datum path- |
-
| 114 | -2x | -
- InfoDirIn <- NEONprocIS.base::def.dir.splt.pach.time(DirDatm,log=log)- |
-
| 115 | -- |
- - |
-
| 116 | -- |
- # Create the error path- |
-
| 117 | -2x | -
- NEONprocIS.base::def.dir.crea(DirBgn=DirErrBase,- |
-
| 118 | -2x | -
- DirSub=InfoDirIn$dirRepo,- |
-
| 119 | -2x | -
- log=log)- |
-
| 120 | -- |
- - |
-
| 121 | -- |
- # Write an empty file- |
-
| 122 | -2x | -
- base::options(digits.secs=3)- |
-
| 123 | -2x | -
- nameFileErr <- base::paste0(DirErrBase,InfoDirIn$dirRepo,'/',utils::tail(InfoDirIn$dirSplt,1))- |
-
| 124 | -2x | -
- con <- base::file(nameFileErr, "w")- |
-
| 125 | -2x | -
- base::close(con)- |
-
| 126 | -- |
- - |
-
| 127 | -- |
- - |
-
| 128 | -- |
- # Remove any partial output for the datum- |
-
| 129 | -2x | -
- if(RmvDatmOut==TRUE && base::is.null(DirOutBase)){
- |
-
| 130 | -- |
- # Something isn't right- |
-
| 131 | -1x | -
- log$error(- |
-
| 132 | -1x | -
- base::paste0(- |
-
| 133 | -1x | -
- 'Cannot remove partial output for errored datum: ',- |
-
| 134 | -1x | -
- DirDatm,- |
-
| 135 | -1x | -
- ' because input argument DirOut is not specified.'- |
-
| 136 | -- |
- )- |
-
| 137 | -- |
- )- |
-
| 138 | -1x | -
- } else if (RmvDatmOut==TRUE){
- |
-
| 139 | -- |
- # Delete partial output- |
-
| 140 | -1x | -
- dirOutDatm <- base::paste0(DirOutBase, InfoDirIn$dirRepo)- |
-
| 141 | -1x | -
- rpt <- base::unlink(dirOutDatm,recursive=TRUE)- |
-
| 142 | -- |
- - |
-
| 143 | -- |
- # Report outcome- |
-
| 144 | -1x | -
- switch(base::as.character(rpt),- |
-
| 145 | -1x | -
- '0'=log$info(- |
-
| 146 | -1x | -
- base::paste0(- |
-
| 147 | -1x | -
- 'Removed partial output for errored datum: ',- |
-
| 148 | -1x | -
- dirOutDatm- |
-
| 149 | -- |
- )- |
-
| 150 | -- |
- ),- |
-
| 151 | -! | -
- '1'=log$info(- |
-
| 152 | -! | -
- base::paste0(- |
-
| 153 | -! | -
- 'Could not remove partial output for errored datum: ',- |
-
| 154 | -! | -
- dirOutDatm,- |
-
| 155 | -! | -
- '. Check that you have the appropriate permissions.'- |
-
| 156 | -- |
- )- |
-
| 157 | -- |
- )- |
-
| 158 | -- |
- )- |
-
| 159 | -- |
- }- |
-
| 160 | -- |
- - |
-
| 161 | -2x | -
- return()- |
-
| 162 | -- |
- }- |
-
| 1 | -- |
- ###################################################################################################- |
-
| 2 | -- |
- #' @title Validate list not empty or invalid- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Mija Choi \email{choim@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Validate a list to check it is not a list or it is not empty.- |
-
| 9 | -- |
- #' Returns True if it is a list and is not empty. FALSE otherwise.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param listIn Input list to be validated- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 14 | -- |
- #' created and used within the function.- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @return Boolean. True if the input it is a list and is not empty. FALSE otherwise. \cr- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @references Currently none- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @keywords Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @examples Currently none- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 25 | -- |
- #'- |
-
| 26 | -- |
- #' @export- |
-
| 27 | -- | - - | -
| 28 | -- |
- # changelog and author contributions / copyrights- |
-
| 29 | -- |
- # Mija Choi (2020-02-24)- |
-
| 30 | -- |
- # original creation- |
-
| 31 | -- |
- ##############################################################################################- |
-
| 32 | -- | - - | -
| 33 | -- |
- def.validate.list <-- |
-
| 34 | -- |
- function(listIn,- |
-
| 35 | -- |
- log = NULL) {
- |
-
| 36 | -- |
- # Initialize logging if necessary- |
-
| 37 | -3x | -
- if (base::is.null(log)) {
- |
-
| 38 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 39 | -- |
- }- |
-
| 40 | -- |
- - |
-
| 41 | -3x | -
- b <- TRUE- |
-
| 42 | -- |
- - |
-
| 43 | -3x | -
- if (!is.list(listIn)) {
- |
-
| 44 | -1x | -
- b <- FALSE- |
-
| 45 | -1x | -
- log$error('Input is not a list.')
- |
-
| 46 | -- |
- }- |
-
| 47 | -- |
- - |
-
| 48 | -2x | -
- else if (length(listIn) ==0) {
- |
-
| 49 | -1x | -
- b <- FALSE- |
-
| 50 | -1x | -
- log$error('List is empty.')
- |
-
| 51 | -- |
- - |
-
| 52 | -- |
- }- |
-
| 53 | -- |
- - |
-
| 54 | -3x | -
- return (b)- |
-
| 55 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Parse AVRO schema to list- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Turn the JSON formatted AVRO schema (either from file or a json string)- |
-
| 9 | -- |
- #' into a formatted list.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param FileSchm String. Optional. Full or relative path to schema file. One of FileSchm or Schm must be- |
-
| 12 | -- |
- #' provided.- |
-
| 13 | -- |
- #' @param Schm String. Optional. Json formatted string of the AVRO file schema. One of FileSchm or Schm must- |
-
| 14 | -- |
- #' be provided. If both Schm and FileSchm are provided, Schm will be ignored.- |
-
| 15 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 16 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 17 | -- |
- #' created for use within this function.- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @return A list of:\cr- |
-
| 20 | -- |
- #' \code{schmJson}: the avro schema in json format\cr
- |
-
| 21 | -- |
- #' \code{schmList}: a list of avro schema properties and fields
- |
-
| 22 | -- |
- #' \code{var}: a data frame of variables/fields in the schema, their data type(s), and documentation string
- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @references- |
-
| 25 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @keywords Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @examples- |
-
| 30 | -- |
- #' NEONprocIS.base::def.schm.avro.pars(FileSchm='/pfs/avro_schemas/prt_calibrated.avsc')- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.avro.deve}
- |
-
| 33 | -- |
- #' @seealso \link[NEONprocIS.base]{def.log.init}
- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @export- |
-
| 36 | -- | - - | -
| 37 | -- |
- # changelog and author contributions / copyrights- |
-
| 38 | -- |
- # Cove Sturtevant (2019-10-25)- |
-
| 39 | -- |
- # original creation- |
-
| 40 | -- |
- ##############################################################################################- |
-
| 41 | -- |
- def.schm.avro.pars <- function(FileSchm=NULL,- |
-
| 42 | -- |
- Schm=NULL,- |
-
| 43 | -- |
- log=NULL- |
-
| 44 | -- |
- ){
- |
-
| 45 | -- |
- - |
-
| 46 | -- |
- # Initialize log if not input- |
-
| 47 | -12x | -
- if(base::is.null(log)){
- |
-
| 48 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 49 | -- |
- }- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # Error check- |
-
| 52 | -12x | -
- if(base::is.null(FileSchm) && base::is.null(Schm)){
- |
-
| 53 | -- |
- # Generate error and stop execution- |
-
| 54 | -2x | -
- msg <- base::paste0('One of FileSchm or Schm must be provided')
- |
-
| 55 | -2x | -
- log$fatal(msg)- |
-
| 56 | -2x | -
- stop(msg)- |
-
| 57 | -- |
- }- |
-
| 58 | -- |
- - |
-
| 59 | -- |
- # Read in the schema file- |
-
| 60 | -10x | -
- if(!base::is.null(FileSchm)){
- |
-
| 61 | -- |
- - |
-
| 62 | -9x | -
- Schm <- base::try(base::paste0(base::readLines(FileSchm),collapse=''),silent=TRUE)- |
-
| 63 | -9x | -
- if(base::class(Schm) == 'try-error'){
- |
-
| 64 | -- |
- - |
-
| 65 | -- |
- # Generate error and stop execution- |
-
| 66 | -1x | -
- msg <- base::paste0('Avro schema file ', FileSchm, ' is unreadable. Error text:',attr(Schm,"condition"))
- |
-
| 67 | -1x | -
- log$fatal(msg)- |
-
| 68 | -1x | -
- stop(msg)- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Interpret as list- |
-
| 73 | -9x | -
- schmList <- rjson::fromJSON(json_str=Schm,simplify=FALSE)- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- # Turn field list into a data frame- |
-
| 76 | -8x | -
- var <- base::lapply(schmList$fields,FUN=function(idx){
- |
-
| 77 | -43x | -
- if(base::is.null(idx$name)){
- |
-
| 78 | -3x | -
- idx$name <- NA- |
-
| 79 | -- |
- }- |
-
| 80 | -43x | -
- if(base::is.null(idx$type)){
- |
-
| 81 | -3x | -
- idx$type <- NA- |
-
| 82 | -- |
- }- |
-
| 83 | -43x | -
- if(base::is.null(idx$doc)){
- |
-
| 84 | -1x | -
- idx$doc <- NA- |
-
| 85 | -- |
- }- |
-
| 86 | -- |
- - |
-
| 87 | -43x | -
- base::data.frame(name=idx$name,type=base::paste0(base::unlist(idx$type),collapse='|'),doc=idx$doc,stringsAsFactors=FALSE)- |
-
| 88 | -- |
- })- |
-
| 89 | -8x | -
- var <- base::do.call(base::rbind,var)- |
-
| 90 | -- |
- - |
-
| 91 | -- |
- # Output- |
-
| 92 | -8x | -
- rpt <- base::list()- |
-
| 93 | -8x | -
- rpt$schmJson <- Schm- |
-
| 94 | -8x | -
- rpt$schmList <- schmList- |
-
| 95 | -8x | -
- rpt$var <- var- |
-
| 96 | -- |
- - |
-
| 97 | -8x | -
- return(rpt)- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Initialize logging for NEON IS Data Processing- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Initialize logging for NEON IS Data Processing. Currently uses the lgr- |
-
| 9 | -- |
- #' package and implements hierarchical logging with options for json formatting and writing to file.- |
-
| 10 | -- |
- #' Note that all parameters default to NULL, in which case an attempt will be made to retrieve the- |
-
| 11 | -- |
- #' system environmental variables specified.- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @param Name String (optional). Name of logger. Defaults to root if environment variable- |
-
| 14 | -- |
- #' LOG_NAME is not found.- |
-
| 15 | -- |
- #' @param To String (optional). Location to log to. Options are 'stdout' (console) or 'file'.- |
-
| 16 | -- |
- #' Defaults to stdout if environment variable LOG_TO is not found.- |
-
| 17 | -- |
- #' @param NameFile String (optional). Name of file, including relative or absolute path, to log to.- |
-
| 18 | -- |
- #' Ingored if To='stdout'. Defaults to ./log.txt if environment variable LOG_FILENAME is not found.- |
-
| 19 | -- |
- #' @param Fmt String (optional). Logging format. Options are 'plain' (human readable text)- |
-
| 20 | -- |
- #' or 'json'. Defaults to plain if environment variable LOG_FORMAT is not found.- |
-
| 21 | -- |
- #' @param Lvl String (optional). The minimum logging level that triggers log output. Options are, in- |
-
| 22 | -- |
- #' order of increasing severity, 'debug','info','warn','error','fatal'.- |
-
| 23 | -- |
- #' Defaults to info if environment variable LOG_LEVEL is not found.- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @return A logger object, configured according to inputs. Logging can now be conducted in the main- |
-
| 26 | -- |
- #' code, using the functions in the lgr package. See example.- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @references- |
-
| 29 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @keywords Currently none- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @examples- |
-
| 34 | -- |
- #' lg <- def.log.init(To='stdout',Fmt='plain','Lvl'='info')- |
-
| 35 | -- |
- #' lg$warn('This is a warning')
- |
-
| 36 | -- |
- #' lg$debug('This debug message will not print because the minimum logging level is info')
- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @seealso Currently none- |
-
| 39 | -- | - - | -
| 40 | -- |
- #' @export- |
-
| 41 | -- | - - | -
| 42 | -- |
- # changelog and author contributions / copyrights- |
-
| 43 | -- |
- # Cove Sturtevant (2019-05-09)- |
-
| 44 | -- |
- # original creation- |
-
| 45 | -- |
- # Cove Sturtevant (2019-06-11)- |
-
| 46 | -- |
- # use list input for logger configuration- |
-
| 47 | -- |
- ##############################################################################################- |
-
| 48 | -- |
- def.log.init <- function(Name=NULL,- |
-
| 49 | -- |
- To=NULL,- |
-
| 50 | -- |
- NameFile=NULL,- |
-
| 51 | -- |
- Fmt=NULL,- |
-
| 52 | -- |
- Lvl=NULL- |
-
| 53 | -- |
- ){
- |
-
| 54 | -- |
- - |
-
| 55 | -- |
- # Load the logging library- |
-
| 56 | -245x | -
- library(lgr)- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # Attempt to retrieve environment variables to set configu parameters- |
-
| 59 | -245x | -
- if(base::is.null(Name)){
- |
-
| 60 | -245x | -
- Name <- base::Sys.getenv('LOG_NAME')
- |
-
| 61 | -245x | -
- if(Name == ""){
- |
-
| 62 | -245x | -
- Name <- NULL- |
-
| 63 | -- |
- }- |
-
| 64 | -- |
- }- |
-
| 65 | -- | - - | -
| 66 | -245x | -
- if(base::is.null(To)){
- |
-
| 67 | -245x | -
- To <- base::Sys.getenv('LOG_TO')
- |
-
| 68 | -245x | -
- if(To == ""){
- |
-
| 69 | -245x | -
- To <- c('stdout','file')[1]
- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- }- |
-
| 72 | -245x | -
- To <- base::tolower(To)- |
-
| 73 | -- |
- - |
-
| 74 | -245x | -
- if(base::is.null(NameFile)){
- |
-
| 75 | -245x | -
- NameFile <- base::Sys.getenv('LOG_FILENAME')
- |
-
| 76 | -245x | -
- if(NameFile == ""){
- |
-
| 77 | -245x | -
- NameFile <- 'log.txt'- |
-
| 78 | -- |
- }- |
-
| 79 | -- |
- }- |
-
| 80 | -- | - - | -
| 81 | -245x | -
- if(base::is.null(Fmt)){
- |
-
| 82 | -245x | -
- Fmt <- base::Sys.getenv('LOG_FORMAT')
- |
-
| 83 | -245x | -
- if(Fmt == ""){
- |
-
| 84 | -245x | -
- Fmt <- c('plain','json')[1]
- |
-
| 85 | -- |
- }- |
-
| 86 | -- |
- }- |
-
| 87 | -245x | -
- Fmt <- base::tolower(Fmt)- |
-
| 88 | -- |
- - |
-
| 89 | -245x | -
- if(base::is.null(Lvl)){
- |
-
| 90 | -245x | -
- Lvl <- base::Sys.getenv('LOG_LEVEL')
- |
-
| 91 | -245x | -
- if(Lvl == ""){
- |
-
| 92 | -! | -
- Lvl <- c('debug','info','warn','error','fatal')[2]
- |
-
| 93 | -- |
- }- |
-
| 94 | -- |
- }- |
-
| 95 | -245x | -
- Lvl <- base::tolower(Lvl)- |
-
| 96 | -- |
- - |
-
| 97 | -- |
- - |
-
| 98 | -- |
- - |
-
| 99 | -- |
- - |
-
| 100 | -- |
- # Set the layout- |
-
| 101 | -245x | -
- lgFmt <- switch(Fmt,- |
-
| 102 | -245x | -
- json=lgr::LayoutJson$new(),- |
-
| 103 | -245x | -
- plain=lgr::LayoutFormat$new()- |
-
| 104 | -- |
- )- |
-
| 105 | -- |
- - |
-
| 106 | -- |
- # Set the appender- |
-
| 107 | -245x | -
- lgTo <- switch(To,- |
-
| 108 | -245x | -
- stdout=lgr::AppenderConsole$new(- |
-
| 109 | -245x | -
- layout=lgFmt- |
-
| 110 | -245x | -
- ),# write to console (stdout) in Fmt format- |
-
| 111 | -245x | -
- file=lgr::AppenderFile$new(- |
-
| 112 | -245x | -
- file=NameFile,- |
-
| 113 | -245x | -
- layout=lgFmt- |
-
| 114 | -245x | -
- ) # write to json file in Fmt- |
-
| 115 | -- |
- )- |
-
| 116 | -- |
- - |
-
| 117 | -- |
- # Initialize the logger- |
-
| 118 | -245x | -
- lg <- lgr::get_logger(Name)- |
-
| 119 | -245x | -
- lg$config(base::list(- |
-
| 120 | -245x | -
- threshold=Lvl,- |
-
| 121 | -245x | -
- appenders=lgTo- |
-
| 122 | -- |
- ))- |
-
| 123 | -- |
- - |
-
| 124 | -245x | -
- lg$set_propagate(FALSE) # Remove inherited appenders (so we don't double log)- |
-
| 125 | -- |
- - |
-
| 126 | -245x | -
- return(lg)- |
-
| 127 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Construct an output file name from an input file name- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Construct an output file name from an input file name, adding a prefix,- |
-
| 9 | -- |
- #' appendix, extension, or all of the above.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param nameFileIn Character value. Input file name serving as a basis for the output file name.- |
-
| 12 | -- |
- #' @param prfx Character value. String to add to the front of nameFileIn. Defaults to NULL.- |
-
| 13 | -- |
- #' @param sufx Character value. String to append to the end of nameFileIn. If there are any- |
-
| 14 | -- |
- #' periods (.) in the input file name, Sufx will be added before the final period.- |
-
| 15 | -- |
- #' Defaults to NULL.- |
-
| 16 | -- |
- #' @param ext Character value. String indicating the extension of the output file name. If- |
-
| 17 | -- |
- #' there are any periods (.) in the input file name, Ext will replace the characters after the- |
-
| 18 | -- |
- #' final period. If there are no periods in the file name. A period followed by Ext will be added- |
-
| 19 | -- |
- #' to the end of the file name. Defaults to NULL.- |
-
| 20 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 21 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 22 | -- |
- #' created and used within the function.- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @return A character vector of input directories (datums)- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @references Currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @keywords Currently none- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @examples- |
-
| 31 | -- |
- #' NEONprocIS.base::def.file.name.out(nameFileIn='myFileName.json',prfx='Prefix_',sufx='_Suffix',ext='txt')- |
-
| 32 | -- | - - | -
| 33 | -- | - - | -
| 34 | -- |
- #' @seealso Currently none- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @export- |
-
| 37 | -- | - - | -
| 38 | -- |
- # changelog and author contributions / copyrights- |
-
| 39 | -- |
- # Cove Sturtevant (2020-02-14)- |
-
| 40 | -- |
- # original creation- |
-
| 41 | -- |
- ##############################################################################################- |
-
| 42 | -- |
- def.file.name.out <- function(nameFileIn,- |
-
| 43 | -- |
- prfx=NULL,- |
-
| 44 | -- |
- sufx=NULL,- |
-
| 45 | -- |
- ext=NULL,- |
-
| 46 | -- |
- log=NULL){
- |
-
| 47 | -- |
- - |
-
| 48 | -- |
- # Initialize log if not input- |
-
| 49 | -5x | -
- if(base::is.null(log)){
- |
-
| 50 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 51 | -- |
- }- |
-
| 52 | -- |
- - |
-
| 53 | -- |
- # Split the file name by periods- |
-
| 54 | -5x | -
- nameFileSplt <- base::strsplit(nameFileIn,'[.]')[[1]] # Try to grab the file name without extension- |
-
| 55 | -- |
- - |
-
| 56 | -- |
- # Add suffix & extension- |
-
| 57 | -5x | -
- if(base::length(nameFileSplt) > 1){
- |
-
| 58 | -- |
- # Replace the extension- |
-
| 59 | -2x | -
- if(!base::is.null(ext)){
- |
-
| 60 | -2x | -
- nameFileSplt[base::length(nameFileSplt)] <- ext- |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- # Add suffix- |
-
| 63 | -2x | -
- nameFileOut <- base::paste0(base::paste0(nameFileSplt[-base::length(nameFileSplt)],collapse='.'),sufx,'.',utils::tail(nameFileSplt,1))- |
-
| 64 | -- |
- } else {
- |
-
| 65 | -3x | -
- if(!base::is.null(ext)){
- |
-
| 66 | -3x | -
- ext <- base::paste0('.',ext)
- |
-
| 67 | -- |
- }- |
-
| 68 | -3x | -
- nameFileOut <- base::paste0(nameFileSplt,sufx,ext)- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # Add prefix- |
-
| 72 | -5x | -
- nameFileOut <- base::paste0(prfx,nameFileOut)- |
-
| 73 | -- |
- - |
-
| 74 | -5x | -
- return(nameFileOut)- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Map data to a parquet schema- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Rearrange and/or create dummy columns in a data frame to match the column- |
-
| 9 | -- |
- #' order of a parquet schema. Optionally convert data type to match the schema.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Data frame with named columns.- |
-
| 12 | -- |
- #' @param schm A Parquet schema of class ArrowObject- |
-
| 13 | -- |
- #' @param ConvType Logical TRUE to attempt to convert the data type to that indicated in the- |
-
| 14 | -- |
- #' schema. FALSE to attempt no type conversion. Default is FALSE.- |
-
| 15 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 16 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @return A data frame that (hopefully) matches the output schema- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @references Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @keywords Currently none- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @examples Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @seealso Currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @export- |
-
| 29 | -- | - - | -
| 30 | -- |
- # changelog and author contributions / copyrights- |
-
| 31 | -- |
- # Cove Sturtevant (2020-04-16)- |
-
| 32 | -- |
- # original creation- |
-
| 33 | -- |
- ##############################################################################################- |
-
| 34 | -- |
- def.data.mapp.schm.parq <- function(data,schm,ConvType=FALSE,log=NULL){
- |
-
| 35 | -- |
- # initialize logging if necessary- |
-
| 36 | -3x | -
- if (base::is.null(log)) {
- |
-
| 37 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 38 | -- |
- }- |
-
| 39 | -- |
- - |
-
| 40 | -- |
- # Parse the schema to get the columns and data types- |
-
| 41 | -3x | -
- infoSchm <- NEONprocIS.base::def.schm.parq.pars(schm)- |
-
| 42 | -3x | -
- nameVarOut <- infoSchm$name- |
-
| 43 | -- |
- - |
-
| 44 | -- |
- # Data columns may be missing and/or out of order. Add dummy columns for those that we're missing- |
-
| 45 | -3x | -
- nameVarAdd <- nameVarOut[!(nameVarOut %in% base::names(data))]- |
-
| 46 | -3x | -
- numData <- base::nrow(data)- |
-
| 47 | -3x | -
- for(idxVarAdd in nameVarAdd){
- |
-
| 48 | -2x | -
- data[[idxVarAdd]] <- base::rep(x=base::as.character(NA),times=numData)- |
-
| 49 | -- |
- }- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # Rearrange to the original columns order & get rid of variables not in the schema- |
-
| 52 | -3x | -
- data <- data[,nameVarOut]- |
-
| 53 | -- |
- - |
-
| 54 | -- |
- # Convert data types- |
-
| 55 | -3x | -
- if(ConvType == TRUE){
- |
-
| 56 | -2x | -
- data <- NEONprocIS.base::def.data.conv.type.parq(data=data,type=infoSchm,log=log)- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- }- |
-
| 59 | -- |
- - |
-
| 60 | -3x | -
- return(data)- |
-
| 61 | -- |
- }- |
-
| 1 | -- |
- ###################################################################################################- |
-
| 2 | -- |
- #' @title validate if the JSON content is strictly valid- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Mija Choi \email{choim@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Validate an input json to check it is valid.- |
-
| 9 | -- |
- #' Returns FALSE if the json is empty OR invaild . TRUE otherwise.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param jsonIn Input json to be validated- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @return Boolean. TRUE if the input json is not empty AND valid. FALSE otherwise. \cr- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @references Currently none- |
-
| 16 | -- | - - | -
| 17 | -- |
- #' @keywords Currently none- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @examples NEONprocIS.base::def.validate.json (NameFileIn)- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 22 | -- |
- #'- |
-
| 23 | -- |
- #' @export- |
-
| 24 | -- | - - | -
| 25 | -- |
- # changelog and author contributions / copyrights- |
-
| 26 | -- |
- # Mija Choi (2020-01-14)- |
-
| 27 | -- |
- # original creation- |
-
| 28 | -- |
- ##############################################################################################- |
-
| 29 | -- |
- #library(RJSONIO)- |
-
| 30 | -- | - - | -
| 31 | -- |
- def.validate.json <- function(jsonIn, log = NULL) {
- |
-
| 32 | -- |
- # Initialize log if not input- |
-
| 33 | -46x | -
- if (base::is.null(log)) {
- |
-
| 34 | -20x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 35 | -- |
- }- |
-
| 36 | -- |
- #set the default to FALSE- |
-
| 37 | -46x | -
- c = FALSE- |
-
| 38 | -- |
- #- |
-
| 39 | -46x | -
- res <- try((RJSONIO::isValidJSON(jsonIn)), silent = TRUE)- |
-
| 40 | -- |
- #- |
-
| 41 | -- |
- # First, check the input json passed on exists- |
-
| 42 | -- |
- #- |
-
| 43 | -46x | -
- if (class(res) == "try-error") {
- |
-
| 44 | -1x | -
- log$error(base::paste0( 'In def.validate.json::::: Error, the file does not exist, ', jsonIn))- |
-
| 45 | -- |
- }- |
-
| 46 | -- |
- #- |
-
| 47 | -- |
- # Then, check if the jsonIn is a valid json- |
-
| 48 | -- |
- #- |
-
| 49 | -46x | -
- if (class(res) != "try-error") {
- |
-
| 50 | -45x | -
- if (RJSONIO::isValidJSON(jsonIn))- |
-
| 51 | -- |
- {
- |
-
| 52 | -43x | -
- c = TRUE- |
-
| 53 | -43x | -
- log$debug(base::paste0(jsonIn, ' is valid strictly.'))- |
-
| 54 | -- |
- }- |
-
| 55 | -- |
- else- |
-
| 56 | -- |
- {
- |
-
| 57 | -2x | -
- log$debug(base::paste0(jsonIn, ' is invalid ***** '))- |
-
| 58 | -- |
- }- |
-
| 59 | -- |
- }- |
-
| 60 | -- |
- - |
-
| 61 | -46x | -
- return (c)- |
-
| 62 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Merge the contents of multiple files (avro or parquet) that share a common time variable.- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Merge the contents of multiple avro or parquet files that share a common time- |
-
| 9 | -- |
- #' variable. Other than the time variable, the files should different columns. If any duplicate- |
-
| 10 | -- |
- #' column names are found, only the first instance found will be retained. Any missing- |
-
| 11 | -- |
- #' timestamps among the files will be filled with NA values.- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @param file Character vector of full or relative file paths. Must be avro or parquet format.- |
-
| 14 | -- |
- #' @param nameVarTime Character value. The name of the time variable common across all files.- |
-
| 15 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 16 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @return A data frame with the merged file contents.- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @references Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @keywords Currently none- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @examples- |
-
| 25 | -- |
- #' # Not run- |
-
| 26 | -- |
- #' file <- c('/path/to/file1.avro','/path/to/file2.avro')
- |
-
| 27 | -- |
- #' NEONprocIS.base::def.file.comb.ts(file=file,nameVarTime='readout_time')- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.avro.deve}
- |
-
| 30 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.parq}
- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @export- |
-
| 33 | -- | - - | -
| 34 | -- |
- # changelog and author contributions / copyrights- |
-
| 35 | -- |
- # Cove Sturtevant (2020-03-11)- |
-
| 36 | -- |
- # original creation- |
-
| 37 | -- |
- # Cove Sturtevant (2020-04-28)- |
-
| 38 | -- |
- # added support for parquet format- |
-
| 39 | -- |
- ##############################################################################################- |
-
| 40 | -- |
- def.file.comb.ts <- function(file,nameVarTime,log = NULL) {
- |
-
| 41 | -- |
- # initialize logging if necessary- |
-
| 42 | -4x | -
- if (base::is.null(log)) {
- |
-
| 43 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 44 | -- |
- }- |
-
| 45 | -- |
- - |
-
| 46 | -4x | -
- for(idxFile in file){
- |
-
| 47 | -- |
- - |
-
| 48 | -- |
- # What format?- |
-
| 49 | -6x | -
- fmt <- utils::tail(base::strsplit(idxFile,'[.]')[[1]],1)- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # Load in file- |
-
| 52 | -6x | -
- if(fmt == 'avro'){
- |
-
| 53 | -1x | -
- idxData <- base::try(NEONprocIS.base::def.read.avro.deve(NameFile=idxFile,NameLib='/ravro.so',log=log),silent=FALSE)- |
-
| 54 | -5x | -
- } else if (fmt == 'parquet'){
- |
-
| 55 | -4x | -
- idxData <- base::try(NEONprocIS.base::def.read.parq(NameFile=idxFile,log=log),silent=FALSE)- |
-
| 56 | -- |
- } else {
- |
-
| 57 | -1x | -
- log$error(base::paste0('Cannot determine file type for ',idxFile,'. Extension must be .avro or .parquet.'))
- |
-
| 58 | -1x | -
- stop()- |
-
| 59 | -- |
- }- |
-
| 60 | -5x | -
- if(base::any(base::class(idxData) == 'try-error')){
- |
-
| 61 | -1x | -
- log$error(base::paste0('File ', idxFile,' is unreadable.'))
- |
-
| 62 | -1x | -
- stop()- |
-
| 63 | -- |
- }- |
-
| 64 | -- |
- - |
-
| 65 | -- |
- # Pull out the time variable- |
-
| 66 | -4x | -
- if(!NEONprocIS.base::def.validate.dataframe(dfIn=idxData,TestNameCol=nameVarTime,log=log)){
- |
-
| 67 | -! | -
- stop()- |
-
| 68 | -- |
- }- |
-
| 69 | -- |
- - |
-
| 70 | -- |
- # If this is the first file, use it as the basis for adding onto in subsequent files- |
-
| 71 | -4x | -
- if(idxFile == file[1]){
- |
-
| 72 | -2x | -
- data <- idxData- |
-
| 73 | -- |
- } else {
- |
-
| 74 | -- |
- # Make sure there are no duplicate columns- |
-
| 75 | -2x | -
- dupCol <- base::names(idxData) %in% base::setdiff(base::names(data),nameVarTime)- |
-
| 76 | -2x | -
- if(base::sum(dupCol) > 0){
- |
-
| 77 | -1x | -
- log$warn(base::paste0('The non-time column names: ',
- |
-
| 78 | -1x | -
- base::paste0(base::names(idxData)[dupCol],collapse=','),- |
-
| 79 | -1x | -
- ' contained in the files ', base::paste0(file,collapse=','),- |
-
| 80 | -1x | -
- ' overlap. Taking the first instance of duplicate column names.')- |
-
| 81 | -- |
- )- |
-
| 82 | -1x | -
- idxData <- idxData[!dupCol]- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # Issue a warning if the timestamps are not identical- |
-
| 86 | -2x | -
- if(!base::all.equal(data[[nameVarTime]],idxData[[nameVarTime]])){
- |
-
| 87 | -! | -
- log$warn(base::paste0('Timestamps in file ',idxFile, ' are not fully consistent with previously loaded files for this datum path. NAs for non-matching times will result (to be turned to -1 later).'))
- |
-
| 88 | -- |
- }- |
-
| 89 | -- |
- - |
-
| 90 | -- |
- # Merge the data- |
-
| 91 | -2x | -
- data <- base::merge(x=data,y=idxData,by=nameVarTime,all=TRUE,sort=FALSE)- |
-
| 92 | -- |
- }- |
-
| 93 | -- |
- } # End loop around input files- |
-
| 94 | -- |
- - |
-
| 95 | -2x | -
- log$info(base::paste0('Successfully merged the contents of ', base::length(file),' files.'))
- |
-
| 96 | -- |
- - |
-
| 97 | -2x | -
- return(data)- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- }- |
-
| 1 | -- |
- ###################################################################################################- |
-
| 2 | -- |
- #' @title validate if the xml content is valid against the xml schema- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Mija Choi \email{choim@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Validate an input xml against the schema to check it is valid.- |
-
| 9 | -- |
- #' Returns TRUE if the xml is vaild . FALSE otherwise.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param xmlIn Input xml to be validated- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @param xmlSchemaIn Input xml schema to be validated against- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @return Boolean. TRUE if the input xml is valid against the schema. FALSE if not valid. \cr- |
-
| 16 | -- | - - | -
| 17 | -- |
- #' @references Currently none- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @keywords Currently none- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @examples NEONprocIS.base::def.validate.json.schema (jsonIn, jsonSchemaIn)- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 24 | -- |
- #'- |
-
| 25 | -- |
- #' @export- |
-
| 26 | -- | - - | -
| 27 | -- |
- # changelog and author contributions / copyrights- |
-
| 28 | -- |
- # Mija Choi (2020-02-28)- |
-
| 29 | -- |
- # original creation- |
-
| 30 | -- |
- ##############################################################################################- |
-
| 31 | -- | - - | -
| 32 | -- |
- def.validate.xml.schema <-- |
-
| 33 | -- |
- function(xmlIn, xmlSchemaIn, log = NULL) {
- |
-
| 34 | -- |
- # Initialize log if not input- |
-
| 35 | -3x | -
- if (base::is.null(log)) {
- |
-
| 36 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 37 | -- |
- }- |
-
| 38 | -- |
- #set the default to FALSE- |
-
| 39 | -3x | -
- d = FALSE- |
-
| 40 | -- |
- - |
-
| 41 | -3x | -
- xml <- try(XML::xmlParse(xmlIn), silent = TRUE)- |
-
| 42 | -- |
- - |
-
| 43 | -3x | -
- if (class(xml)[1] == "try-error") {
- |
-
| 44 | -1x | -
- log$error(base::paste0(xmlIn, ' does not exist or is unreadable '))- |
-
| 45 | -- |
- }- |
-
| 46 | -- |
- else {
- |
-
| 47 | -2x | -
- xmlFile <- xml2::read_xml(xmlIn)- |
-
| 48 | -2x | -
- xmlFileXsd <- xml2::read_xml(xmlSchemaIn)- |
-
| 49 | -- |
- - |
-
| 50 | -- |
- #- |
-
| 51 | -- |
- # TRUE if xmlIn is a valid xml against the schema. FALSE if invalid or error- |
-
| 52 | -- |
- #- |
-
| 53 | -2x | -
- log$debug(- |
-
| 54 | -2x | -
- base::paste0(- |
-
| 55 | -2x | -
- 'Validate.xml.schema: Checking to see if the xml conforms to the schema.'- |
-
| 56 | -- |
- )- |
-
| 57 | -- |
- )- |
-
| 58 | -2x | -
- if (xml2::xml_validate(xmlFile, xmlFileXsd)) {
- |
-
| 59 | -1x | -
- d = TRUE- |
-
| 60 | -1x | -
- log$debug(base::paste0(xmlIn, ' conforms to the schema '))- |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- else- |
-
| 63 | -- |
- {
- |
-
| 64 | -1x | -
- log$error(base::paste0(xmlIn, ' does not conform to the schema '))- |
-
| 65 | -- |
- }- |
-
| 66 | -- |
- }- |
-
| 67 | -3x | -
- return (d)- |
-
| 68 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Map input variable names to output variable names- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Create a data frame that maps input variable names to output variable names- |
-
| 9 | -- |
- #' given vectors of each. Option to add additional variable names that are the same in and out.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param nameVarIn String vector of input variable names. Defaults to zero-length character vector.- |
-
| 12 | -- |
- #' @param nameVarOut String vector of output variable names matched to the same relative position- |
-
| 13 | -- |
- #' of nameVarIn. Defaults to zero-length character vector.- |
-
| 14 | -- |
- #' @param nameVarDfltSame String vector of variable names that are to be mapped the same in & out- |
-
| 15 | -- |
- #' if they are not indicated in nameVarIn. Defaults to zero-length character vector.- |
-
| 16 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 17 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @return A data frame of \cr- |
-
| 20 | -- |
- #' \code{nameVarIn} Character. Input variable names
- |
-
| 21 | -- |
- #' \code{nameVarOut} Character. Output variable names
- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @references Currently none- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @keywords Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @examples- |
-
| 28 | -- |
- #' NEONprocIS.base::def.var.mapp.in.out(nameVarIn=c('varIn1','varIn2'),
- |
-
| 29 | -- |
- #' nameVarOut=c('nameOut1','nameOut2'),
- |
-
| 30 | -- |
- #' nameVarDfltSame=c('nameSame1','nameSame2'))
- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @seealso Currently none- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @export- |
-
| 35 | -- | - - | -
| 36 | -- |
- # changelog and author contributions / copyrights- |
-
| 37 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 38 | -- |
- # original creation- |
-
| 39 | -- |
- # Cove Sturtevant (2020-07-01)- |
-
| 40 | -- |
- # add error catching for non-unique input-output variable names- |
-
| 41 | -- |
- ##############################################################################################- |
-
| 42 | -- |
- def.var.mapp.in.out <- function(nameVarIn=base::character(0),- |
-
| 43 | -- |
- nameVarOut=base::character(0),- |
-
| 44 | -- |
- nameVarDfltSame=base::character(0),- |
-
| 45 | -- |
- log=NULL){
- |
-
| 46 | -- |
- # initialize logging if necessary- |
-
| 47 | -5x | -
- if (base::is.null(log)) {
- |
-
| 48 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 49 | -- |
- }- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- - |
-
| 52 | -5x | -
- if(base::length(nameVarIn) != base::length(nameVarOut)){
- |
-
| 53 | -1x | -
- log$fatal(base::paste0('Number of input variable names does not match number of output variable names.'))
- |
-
| 54 | -1x | -
- stop()- |
-
| 55 | -- |
- }- |
-
| 56 | -- |
- - |
-
| 57 | -- |
- # Error check that nameVarIn entries are unique- |
-
| 58 | -4x | -
- if(base::length(base::unique(nameVarIn)) != length(nameVarIn)){
- |
-
| 59 | -1x | -
- log$fatal(base::paste0('Each of the values in nameVarIn must be unique.'))
- |
-
| 60 | -1x | -
- stop()- |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- - |
-
| 63 | -- |
- # Error check that output names nameVarOut are unique and not overlapping with namveVarDfltSame- |
-
| 64 | -3x | -
- nameVarOutChk <- c(nameVarOut,nameVarDfltSame[!(nameVarDfltSame %in% nameVarIn)])- |
-
| 65 | -3x | -
- if(base::length(base::unique(nameVarOutChk)) != length(nameVarOutChk)){
- |
-
| 66 | -1x | -
- log$fatal(base::paste0('Output variable names must be unique and/or you cannot rename a variable to one of the values in nameVarDfltSame unless the value in nameVarDfltSame is also in nameVarIn.'))
- |
-
| 67 | -1x | -
- stop()- |
-
| 68 | -- |
- }- |
-
| 69 | -- |
- - |
-
| 70 | -2x | -
- mappNameVar <- base::data.frame(nameVarIn=nameVarIn,nameVarOut=nameVarOut,stringsAsFactors=FALSE)- |
-
| 71 | -2x | -
- newVar <- nameVarDfltSame[!(nameVarDfltSame %in% nameVarIn)]- |
-
| 72 | -2x | -
- mappNameVar <- base::rbind(mappNameVar,base::data.frame(nameVarIn=newVar,nameVarOut=newVar,stringsAsFactors = FALSE))- |
-
| 73 | -- |
- - |
-
| 74 | -2x | -
- return(mappNameVar)- |
-
| 75 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Rename columns of a dataframe based on variable mapping- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Rename the columns of a data frame based on variable name mapping.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param df Data frame.- |
-
| 11 | -- |
- #' @param mappNameVar A data frame providing the input/output variable names, as output from- |
-
| 12 | -- |
- #' NEONprocIS.base::mapp.var.in.out. Columns are:\cr- |
-
| 13 | -- |
- #' \code{nameVarIn} Character. Input column name.\cr
- |
-
| 14 | -- |
- #' \code{nameVarOut} Character. Input column name.\cr
- |
-
| 15 | -- |
- #' Defaults to NULL. In which case the output column names will match the input column names.- |
-
| 16 | -- |
- #' Any column names in df not found in mappNameVar$nameVarIn will retain their original names.- |
-
| 17 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 18 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @return A data frame with renamed columns.- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @references Currently none- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @keywords Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @examples- |
-
| 27 | -- |
- #' NEONprocIS.base::def.df.renm(df=data.frame(X=c(1,2,3),Y=c(4,5,6)),- |
-
| 28 | -- |
- #' mappNameVar=data.frame(- |
-
| 29 | -- |
- #' nameVarIn=c('X','Y'),
- |
-
| 30 | -- |
- #' nameVarOut=c('A','B'),
- |
-
| 31 | -- |
- #' stringsAsFactors=FALSE))- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.var.mapp.in.out}
- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @export- |
-
| 36 | -- | - - | -
| 37 | -- |
- # changelog and author contributions / copyrights- |
-
| 38 | -- |
- # Cove Sturtevant (2020-02-14)- |
-
| 39 | -- |
- # original creation- |
-
| 40 | -- |
- ##############################################################################################- |
-
| 41 | -- |
- def.df.renm <- function(df,- |
-
| 42 | -- |
- mappNameVar = NULL,- |
-
| 43 | -- |
- log = NULL) {
- |
-
| 44 | -- |
- # initialize logging if necessary- |
-
| 45 | -1x | -
- if (base::is.null(log)) {
- |
-
| 46 | -1x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 47 | -- |
- }- |
-
| 48 | -- |
- - |
-
| 49 | -1x | -
- varDf <- base::names(df)- |
-
| 50 | -- |
- - |
-
| 51 | -1x | -
- varQfOut <-- |
-
| 52 | -1x | -
- base::unlist(base::lapply(- |
-
| 53 | -1x | -
- varDf,- |
-
| 54 | -1x | -
- FUN = function(idxNameIn) {
- |
-
| 55 | -2x | -
- idxNameOut <-- |
-
| 56 | -2x | -
- mappNameVar$nameVarOut[mappNameVar$nameVarIn == idxNameIn]- |
-
| 57 | -2x | -
- if (base::is.null(idxNameOut)) {
- |
-
| 58 | -! | -
- idxNameOut <- idxNameIn- |
-
| 59 | -- |
- }- |
-
| 60 | -2x | -
- return(idxNameOut)- |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- ))- |
-
| 63 | -- |
- - |
-
| 64 | -1x | -
- base::names(df) <- varQfOut- |
-
| 65 | -- |
- - |
-
| 66 | -1x | -
- return(df)- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read in a parquet dataset- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in multiple parquet files with the same schema into an arrow dataset.- |
-
| 9 | -- |
- #' Optionally limit to selected variables and order by time.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param fileIn Character vector. Names (including relative or absolute path) of parquet files.- |
-
| 12 | -- |
- #' These files must all have the same parquet schema. This can also be a directory, in which case- |
-
| 13 | -- |
- #' all files in the directory will be read into the dataset.- |
-
| 14 | -- |
- #' @param Var Optional. Character vector. Names of the fields/variables in the parquet dataset- |
-
| 15 | -- |
- #' to retain, ordered the same as Var. Only those present in the dataset will be output.- |
-
| 16 | -- |
- #' @param VarTime Optional. Character value of the time variable to order by. If NULL, no ordering- |
-
| 17 | -- |
- #' is performed.- |
-
| 18 | -- |
- #' @param RmvDupl Optional. Boolean. TRUE to remove duplicated rows in the data (as defined by the Var columns). Defaults to FALSE.- |
-
| 19 | -- |
- #' @param Df Optional. Boolean. TRUE to return a data frame with the combined dataset. Defaults to FALSE.- |
-
| 20 | -- |
- #'- |
-
| 21 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 22 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 23 | -- |
- #'- |
-
| 24 | -- |
- #' @return If Df is TRUE, a dataframe of the combined output. Any time variables are converted to POSIXct- |
-
| 25 | -- |
- #' and converted to GMT. If Df is FALSE, an object of class arrow_dplyr_query, which can be further- |
-
| 26 | -- |
- #' manipulated using dplyr. Note that no time zone conversion is performed for the arrow_dplyr_query- |
-
| 27 | -- |
- #' object.- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @references- |
-
| 30 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @keywords Currently none- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @examples- |
-
| 35 | -- |
- #' # NOT RUN- |
-
| 36 | -- |
- #' fileIn <- c('path/to/file1.parquet','path/to/file2.parquet')
- |
-
| 37 | -- |
- #' data <- NEONprocIS.base::def.read.parq.ds(fileIn,VarTime='readout_time',Df=TRUE)- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @seealso Currently none- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @export- |
-
| 42 | -- | - - | -
| 43 | -- |
- # changelog and author contributions / copyrights- |
-
| 44 | -- |
- # Cove Sturtevant (2023-03-07)- |
-
| 45 | -- |
- # original creation- |
-
| 46 | -- |
- # Cove Sturtevant (2023-11-13)- |
-
| 47 | -- |
- # add option to remove duplicated rows- |
-
| 48 | -- |
- ##############################################################################################- |
-
| 49 | -- |
- def.read.parq.ds <- function(fileIn,- |
-
| 50 | -- |
- Var=NULL,- |
-
| 51 | -- |
- VarTime=NULL,- |
-
| 52 | -- |
- RmvDupl=FALSE,- |
-
| 53 | -- |
- Df=FALSE,- |
-
| 54 | -- |
- log=NULL- |
-
| 55 | -- |
- ){
- |
-
| 56 | -- |
- - |
-
| 57 | -5x | -
- library(dplyr)- |
-
| 58 | -- |
- - |
-
| 59 | -- |
- # initialize logging if necessary- |
-
| 60 | -5x | -
- if (base::is.null(log)) {
- |
-
| 61 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 62 | -- |
- }- |
-
| 63 | -- |
- - |
-
| 64 | -- |
- # Load data files into an arrow dataset- |
-
| 65 | -5x | -
- data <- arrow::open_dataset(fileIn,unify_schemas = TRUE)- |
-
| 66 | -5x | -
- varData <- base::names(data$schema)- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Pull the columns matching Var, sort by readout_time- |
-
| 69 | -5x | -
- if(base::length(Var) == 0){
- |
-
| 70 | -3x | -
- Var <- varData- |
-
| 71 | -- |
- }- |
-
| 72 | -5x | -
- varMtch <- Var[Var %in% varData]- |
-
| 73 | -5x | -
- dataMtch <- data %>%- |
-
| 74 | -5x | -
- dplyr::select(dplyr::all_of(varMtch))- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Order by time, if selected- |
-
| 77 | -5x | -
- if(!base::is.null(VarTime)){
- |
-
| 78 | -3x | -
- dataMtch <- dataMtch %>%- |
-
| 79 | -3x | -
- dplyr::arrange(!! rlang::sym(VarTime))- |
-
| 80 | -- |
- }- |
-
| 81 | -- |
- - |
-
| 82 | -- |
- # Get rid of duplicates if selected- |
-
| 83 | -5x | -
- if(RmvDupl == TRUE){
- |
-
| 84 | -1x | -
- dataMtch <- dataMtch %>%- |
-
| 85 | -1x | -
- dplyr::distinct()- |
-
| 86 | -- |
- }- |
-
| 87 | -- |
- - |
-
| 88 | -- |
- # Return a data frame, if selected. Otherwise return arrow table.- |
-
| 89 | -5x | -
- if(Df == TRUE){
- |
-
| 90 | -4x | -
- dataMtch <- dataMtch %>%- |
-
| 91 | -4x | -
- dplyr::collect()- |
-
| 92 | -- |
- - |
-
| 93 | -4x | -
- dataMtch <- base::data.frame(dataMtch)- |
-
| 94 | -4x | -
- base::attr(dataMtch,'schema') <- data$schema- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- # Assign timezone for POSIX variables- |
-
| 97 | -4x | -
- clssVar <- base::lapply(X=dataMtch,FUN=base::class)- |
-
| 98 | -4x | -
- setTime <- base::unlist(base::lapply(X=clssVar,FUN=function(idxClss){base::any(base::grepl(pattern='POSIX',x=idxClss))}))
- |
-
| 99 | -4x | -
- for (idxVar in base::names(dataMtch)[setTime]){
- |
-
| 100 | -6x | -
- base::attr(dataMtch[[idxVar]],'tzone') <- 'GMT'- |
-
| 101 | -- |
- }- |
-
| 102 | -- |
- - |
-
| 103 | -4x | -
- return(dataMtch)- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- } else {
- |
-
| 106 | -- |
- - |
-
| 107 | -1x | -
- return(dataMtch)- |
-
| 108 | -- |
- - |
-
| 109 | -- |
- }- |
-
| 110 | -- |
- - |
-
| 111 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Parse vectors into key:multi-value sets- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Parse the elements of one or more vectors into key:multiple value sets- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param listVect A list of vectors of class numeric or character. Each vector must be length 2 or greater.- |
-
| 11 | -- |
- #' @param NameList Character vector of length 2 indicating first the name to call the- |
-
| 12 | -- |
- #' key in each output list, and then the name to call the value in each output list- |
-
| 13 | -- |
- #' Names default to key and value if not input.- |
-
| 14 | -- |
- #' @param Type A 2-element vector indicating the respective R data classes of the key and- |
-
| 15 | -- |
- #' value. Defaults to the class of listVect.- |
-
| 16 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 17 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 18 | -- |
- #' created and used within the function.- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @return A list of lists numbering the length of with two elements, the key and value(s), except named according to NameList- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @references- |
-
| 23 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @keywords Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @examples- |
-
| 28 | -- |
- #' # Vector input represents key:multi-value set- |
-
| 29 | -- |
- #' listVect <- list(c('key1','1.5','3','4','5'),c('key2','3'))
- |
-
| 30 | -- |
- #' NameList <- c('MyKey','MyValues')
- |
-
| 31 | -- |
- #' Type <- c('character','numeric')
- |
-
| 32 | -- |
- #' NEONprocIS.base::def.vect.pars.one.many(listVect=listVect,NameList=NameList,Type=Type)- |
-
| 33 | -- | - - | -
| 34 | -- | - - | -
| 35 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.arg.pars}}
- |
-
| 36 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.vect.pars.pair}}
- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @export- |
-
| 39 | -- | - - | -
| 40 | -- |
- # changelog and author contributions / copyrights- |
-
| 41 | -- |
- # Cove Sturtevant (2020-03-11)- |
-
| 42 | -- |
- # original creation- |
-
| 43 | -- |
- # Cove Sturtevant (2020-06-18)- |
-
| 44 | -- |
- # bug fix - output lists were not named according to input argument- |
-
| 45 | -- |
- ##############################################################################################- |
-
| 46 | -- |
- def.vect.pars.one.many <- function(listVect,- |
-
| 47 | -- |
- NameList=c('key','value'),
- |
-
| 48 | -- |
- Type=rep(base::class(listVect[[1]]),2),- |
-
| 49 | -- |
- log=NULL){
- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # initialize logging if necessary- |
-
| 52 | -5x | -
- if (base::is.null(log)) {
- |
-
| 53 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 54 | -- |
- }- |
-
| 55 | -- |
- - |
-
| 56 | -- |
- # Error check- |
-
| 57 | -5x | -
- if(!base::is.list(listVect)){
- |
-
| 58 | -2x | -
- log$fatal(base::paste0('listVect must be a list.'))
- |
-
| 59 | -2x | -
- base::stop()- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- - |
-
| 63 | -3x | -
- numVect <- base::unlist(base::lapply(listVect,base::length))- |
-
| 64 | -3x | -
- if(base::any(numVect < 2)){
- |
-
| 65 | -1x | -
- log$fatal(base::paste0('Length of each vector in listVect must be 2 or greater.'))
- |
-
| 66 | -1x | -
- base::stop()- |
-
| 67 | -- |
- }- |
-
| 68 | -- |
- - |
-
| 69 | -2x | -
- if(base::length(NameList) != 2){
- |
-
| 70 | -1x | -
- log$fatal('Length of NameList must be 2.')
- |
-
| 71 | -1x | -
- base::stop()- |
-
| 72 | -- |
- }- |
-
| 73 | -- |
- - |
-
| 74 | -1x | -
- if(length(Type) != 2){
- |
-
| 75 | -! | -
- log$fatal('Length of Type must be 2.')
- |
-
| 76 | -! | -
- base::stop()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # Parse the key-value sets- |
-
| 80 | -1x | -
- rpt <- base::lapply(- |
-
| 81 | -1x | -
- listVect,- |
-
| 82 | -1x | -
- FUN = function(idxVect) {
- |
-
| 83 | -2x | -
- rptIdx <- base::list(- |
-
| 84 | -2x | -
- key = idxVect[1],- |
-
| 85 | -2x | -
- value = utils::tail(x = idxVect, n = -1)- |
-
| 86 | -- |
- )- |
-
| 87 | -- |
- - |
-
| 88 | -- |
- # Assign classes- |
-
| 89 | -2x | -
- base::class(rptIdx$key) <- Type[1]- |
-
| 90 | -2x | -
- base::class(rptIdx$value) <- Type[2]- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- # Rename list- |
-
| 93 | -2x | -
- names(rptIdx) <- NameList- |
-
| 94 | -- |
- - |
-
| 95 | -2x | -
- return(rptIdx)- |
-
| 96 | -- |
- }- |
-
| 97 | -- |
- )- |
-
| 98 | -- |
- - |
-
| 99 | -1x | -
- return(rpt)- |
-
| 100 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Parse vector into key:value pairs- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Parse the elements of a vector into key:value pairs.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param vect Vector of class numeric or character. If length of vect is 1, all expected- |
-
| 11 | -- |
- #' keys indicated in KeyExpc will be assigned this value. If length of vect is in multiples- |
-
| 12 | -- |
- #' of 2, the first value of each pair is assigned the key and the second value of each pair- |
-
| 13 | -- |
- #' is assigned the value.- |
-
| 14 | -- |
- #' @param KeyExpc A vector of expected keys. If these are missing in vect, they will be created.- |
-
| 15 | -- |
- #' Each missing key will be assigned the value of vect if it is length 1, otherwise the value in- |
-
| 16 | -- |
- #' ValuDflt. Defaults to NULL, in which case no checking for missing keys will be done. Must not- |
-
| 17 | -- |
- #' be NULL if vect is a single value.- |
-
| 18 | -- |
- #' @param ValuDflt A single value (character or numeric) of the default value to assign any keys- |
-
| 19 | -- |
- #' in KeyExpc that are not found in vect. Note that if vect is length 1, any missing keys will- |
-
| 20 | -- |
- #' be assigned the value in vect rather than ValuDflt. Defaults to NA.- |
-
| 21 | -- |
- #' @param NameCol Character vector of length 2 indicating the names of the output columns.- |
-
| 22 | -- |
- #' Column names default to key and value.- |
-
| 23 | -- |
- #' @param Type A 2-element vector indicating the respective R data classes of the keys and- |
-
| 24 | -- |
- #' values. Defaults to the class of vect.- |
-
| 25 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 26 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 27 | -- |
- #' created and used within the function.- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @return A data frame with parsed key:value pairs.- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @references- |
-
| 32 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @keywords Currently none- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @examples- |
-
| 37 | -- |
- #' # Vector input represents key:value pairs- |
-
| 38 | -- |
- #' vect <- c('key1','1.5')
- |
-
| 39 | -- |
- #' KeyExpc <- c('key1','key2','key3')
- |
-
| 40 | -- |
- #' ValuDflt <- 3- |
-
| 41 | -- |
- #' NameCol <- c('MyKey','MyValue')
- |
-
| 42 | -- |
- #' Type <- c('character','numeric')
- |
-
| 43 | -- |
- #' NEONprocIS.base::def.vect.pars.pair(vect=vect,KeyExp=KeyExpc,ValuDflt=ValuDflt,NameCol=NameCol,Type=Type)- |
-
| 44 | -- |
- #'- |
-
| 45 | -- |
- #' # Single value input for vect- |
-
| 46 | -- |
- #' vect <- 5- |
-
| 47 | -- |
- #' KeyExpc <- c('key1','key2','key3')
- |
-
| 48 | -- |
- #' NameCol <- c('MyKey','MyValue')
- |
-
| 49 | -- |
- #' Type <- c('character','numeric')
- |
-
| 50 | -- |
- #' NEONprocIS.base::def.vect.pars.pair(vect=vect,KeyExp=KeyExpc,NameCol=NameCol,Type=Type)- |
-
| 51 | -- | - - | -
| 52 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.arg.pars}}
- |
-
| 53 | -- | - - | -
| 54 | -- |
- #' @export- |
-
| 55 | -- | - - | -
| 56 | -- |
- # changelog and author contributions / copyrights- |
-
| 57 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 58 | -- |
- # original creation- |
-
| 59 | -- |
- ##############################################################################################- |
-
| 60 | -- |
- def.vect.pars.pair <- function(vect,- |
-
| 61 | -- |
- KeyExpc=NULL,- |
-
| 62 | -- |
- ValuDflt=NA,- |
-
| 63 | -- |
- NameCol=c('key','value'),
- |
-
| 64 | -- |
- Type=rep(base::class(vect),2),- |
-
| 65 | -- |
- log=NULL){
- |
-
| 66 | -- |
- - |
-
| 67 | -- |
- # initialize logging if necessary- |
-
| 68 | -7x | -
- if (base::is.null(log)) {
- |
-
| 69 | -7x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Error check- |
-
| 73 | -7x | -
- numVect <- base::length(vect)- |
-
| 74 | -7x | -
- if(numVect!=1 && numVect %% 2 > 0){
- |
-
| 75 | -1x | -
- log$fatal(base::paste0('Length of vect must be 1 or a multiple of 2.'))
- |
-
| 76 | -1x | -
- base::stop()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -6x | -
- if(base::length(NameCol) != 2){
- |
-
| 80 | -1x | -
- log$fatal('Length of NameCol must be 2.')
- |
-
| 81 | -1x | -
- stop()- |
-
| 82 | -- |
- }- |
-
| 83 | -- |
- - |
-
| 84 | -5x | -
- if(base::length(ValuDflt) != 1){
- |
-
| 85 | -1x | -
- log$fatal('Length of ValuDflt must be 1.')
- |
-
| 86 | -1x | -
- base::stop()- |
-
| 87 | -- |
- }- |
-
| 88 | -- |
- - |
-
| 89 | -4x | -
- if(length(Type) != 2){
- |
-
| 90 | -1x | -
- log$fatal('Length of Type must be 2.')
- |
-
| 91 | -1x | -
- base::stop()- |
-
| 92 | -- |
- }- |
-
| 93 | -- |
- - |
-
| 94 | -3x | -
- if(numVect == 1 && base::length(KeyExpc) == 0){
- |
-
| 95 | -1x | -
- log$fatal('Length of KeyExpc must be greater than 0 if length of vect is 1.')
- |
-
| 96 | -1x | -
- base::stop()- |
-
| 97 | -- |
- }- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- # Assign key:value pairs- |
-
| 100 | -2x | -
- numVect <- base::length(vect)- |
-
| 101 | -2x | -
- if(numVect > 1){
- |
-
| 102 | -1x | -
- rpt <- base::data.frame(key=vect[base::seq.int(from=1,to=numVect,by=2)],- |
-
| 103 | -1x | -
- value=vect[base::seq.int(from=2,to=numVect,by=2)],- |
-
| 104 | -1x | -
- stringsAsFactors = FALSE)- |
-
| 105 | -- |
- } else {
- |
-
| 106 | -1x | -
- rpt <- base::data.frame(key=KeyExpc,value=vect,stringsAsFactors = FALSE)- |
-
| 107 | -- |
- }- |
-
| 108 | -- |
- - |
-
| 109 | -- |
- # Fill in missing keys- |
-
| 110 | -2x | -
- keyMiss <- KeyExpc[!(KeyExpc %in% rpt$key)] # missing keys- |
-
| 111 | -2x | -
- if(base::length(keyMiss) > 0){
- |
-
| 112 | -- |
- # Fill missing keys with default value- |
-
| 113 | -1x | -
- rpt <- base::rbind(rpt,base::data.frame(key=keyMiss,value=ValuDflt,stringsAsFactors = FALSE)) # Fill in with default- |
-
| 114 | -- |
- }- |
-
| 115 | -- |
- - |
-
| 116 | -- |
- # Assign classes- |
-
| 117 | -2x | -
- base::class(rpt$key) <- Type[1]- |
-
| 118 | -2x | -
- base::class(rpt$value) <- Type[2]- |
-
| 119 | -- |
- - |
-
| 120 | -- |
- # Assign column names- |
-
| 121 | -2x | -
- base::names(rpt) <- NameCol- |
-
| 122 | -- |
- - |
-
| 123 | -2x | -
- return(rpt)- |
-
| 124 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Split Pachyderm directory into component folders and interpret date embedded in directory structure- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Parse the directory structure of a Pachyderm repository located in a Docker container into- |
-
| 9 | -- |
- #' its components and read the date optionally embedded within the file path.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param dir String. Directory path (often found as an environment variable named as the input repository), structured as- |
-
| 12 | -- |
- #' follows: #/pfs/BASE_REPO/#/yyyy/mm/dd/#, where # indicates any number (including zero) of- |
-
| 13 | -- |
- #' parent and child directories of any name, so long as they are not 'pfs' or recognizable as the '/yyyy/mm/dd' structure which- |
-
| 14 | -- |
- #' indicates the 4-digit year, 2-digit month, and 2-digit day.- |
-
| 15 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 16 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 17 | -- |
- #' created and used within the function.- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @return A named list:\cr- |
-
| 20 | -- |
- #' \itemize{
- |
-
| 21 | -- |
- #' \item dirSplt = Character vector of the directory parents and children split into separate character strings (parsed by /)\cr- |
-
| 22 | -- |
- #' \item repo = Character. The repository name (the child directory of /pfs)\cr- |
-
| 23 | -- |
- #' \item idxRepo = Numeric. The index within \code{dirSplt} indicating the position of \code{repo}\cr
- |
-
| 24 | -- |
- #' \item dirRepo = Character. The directory structure within \code{repo}.\cr
- |
-
| 25 | -- |
- #' \item time = POSIXct. The /yyyy/mm/dd date (GMT) embedded within the directory structure (if present). NULL if cannot be interpreted.- |
-
| 26 | -- |
- #' }- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @references Currently none- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @keywords Currently none- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @examples Currently none- |
-
| 33 | -- |
- #' def.dir.splt.pach.time('/scratch/pfs/proc_group/prt/27134/2019/01/01')
- |
-
| 34 | -- | - - | -
| 35 | -- | - - | -
| 36 | -- |
- #' @seealso Currently none- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @export- |
-
| 39 | -- | - - | -
| 40 | -- |
- # changelog and author contributions / copyrights- |
-
| 41 | -- |
- # Cove Sturtevant (2019-03-18)- |
-
| 42 | -- |
- # original creation- |
-
| 43 | -- |
- # Cove Sturtevant (2019-05-20)- |
-
| 44 | -- |
- # fixed bug causing bad interpretation of repo structure when the terminal directory is the repo- |
-
| 45 | -- |
- # Cove Sturtevant (2023-03-08)- |
-
| 46 | -- |
- # add error catching when the repo structure does not match expectations- |
-
| 47 | -- |
- ##############################################################################################- |
-
| 48 | -- |
- def.dir.splt.pach.time <- function(dir,- |
-
| 49 | -- |
- log=NULL- |
-
| 50 | -- |
- ){
- |
-
| 51 | -- |
- - |
-
| 52 | -- |
- - |
-
| 53 | -- |
- # initialize logging if necessary- |
-
| 54 | -6x | -
- if (base::is.null(log)) {
- |
-
| 55 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 56 | -- |
- }- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # Split the directory into parents and children, and parse basic components- |
-
| 59 | -6x | -
- dirSplt <- base::strsplit(dir,'/',fixed=TRUE)[[1]]- |
-
| 60 | -6x | -
- idxRepo <- base::which(dirSplt=='pfs')+1- |
-
| 61 | -6x | -
- if(base::length(idxRepo) == 0){
- |
-
| 62 | -1x | -
- log$error('pfs directory not found in input path structure. Check input repo.')
- |
-
| 63 | -1x | -
- stop()- |
-
| 64 | -- |
- }- |
-
| 65 | -5x | -
- repo <- dirSplt[idxRepo]- |
-
| 66 | -5x | -
- if(base::is.na(repo)){
- |
-
| 67 | -1x | -
- log$error('Cannot determine repo name. Repository structure must conform to .../pfs/repoName/repoContents.... Check input repo.')
- |
-
| 68 | -1x | -
- stop()- |
-
| 69 | -- |
- }- |
-
| 70 | -4x | -
- dirRepo <- base::paste0(c('',dirSplt[base::seq.int(from=idxRepo+1,length.out=base::length(dirSplt)-idxRepo)]),collapse='/')
- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Interpret (if possible) the date embedded within the directory structure- |
-
| 73 | -4x | -
- idxTimeBgn <- base::regexpr(pattern=,'/[0-9]{4}/[0-9]{2}/[0-9]{2}',text=dir)
- |
-
| 74 | -4x | -
- if(idxTimeBgn != -1){
- |
-
| 75 | -3x | -
- time <- base::as.POSIXct(base::substr(x=dir,start=idxTimeBgn[1]+1,stop=idxTimeBgn[1]+10),format='%Y/%m/%d',tz='GMT')- |
-
| 76 | -- |
- } else {
- |
-
| 77 | -1x | -
- time <- NULL- |
-
| 78 | -- |
- }- |
-
| 79 | -- |
- - |
-
| 80 | -- |
- - |
-
| 81 | -- |
- # Output- |
-
| 82 | -4x | -
- rpt <- base::list(dirSplt=dirSplt,repo=repo,idxRepo=idxRepo,dirRepo=dirRepo,time=time)- |
-
| 83 | -4x | -
- return(rpt)- |
-
| 84 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Fill in missing timeseries records and NA-out corrupt records- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Given a set of timestamps indicating missing or corrupt records, fill in- |
-
| 9 | -- |
- #' missing or corrupt timeseries records with a specific value.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Data frame with at least two columns, one of which must be:- |
-
| 12 | -- |
- #' \code{readout_time} POSIXct timestamps
- |
-
| 13 | -- |
- #' @param timeBad A data frame with one column:- |
-
| 14 | -- |
- #' \code{readout_time} POSIXct timestamps signifying missing or corrupt records
- |
-
| 15 | -- |
- #' @param valuBad the value to fill the records with. Defaults to NA.- |
-
| 16 | -- | - - | -
| 17 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 18 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @return A data frame with the same columns as \code{data}. Any timestamps contained in \code{timeBad}
- |
-
| 21 | -- |
- #' but not found in \code{data} are filled in with other values as NA. Any timestamps found in both
- |
-
| 22 | -- |
- #' \code{timeBad} and \code{data} have all values except readout_time set to NA.
- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @references Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @keywords Currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @examples- |
-
| 29 | -- |
- #' NEONprocIS.base::def.rcd.fix.miss.na(nameFile=c('/path/to/file1.avro','/another/path/to/file2.avro'))
- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @seealso \link[NEONprocIS.base]{def.rcd.miss.na}
- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @export- |
-
| 34 | -- | - - | -
| 35 | -- |
- # changelog and author contributions / copyrights- |
-
| 36 | -- |
- # Cove Sturtevant (2020-03-04)- |
-
| 37 | -- |
- # original creation- |
-
| 38 | -- |
- ##############################################################################################- |
-
| 39 | -- |
- def.rcd.fix.miss.na <-- |
-
| 40 | -- |
- function(data,- |
-
| 41 | -- |
- timeBad,- |
-
| 42 | -- |
- valuBad = NA,- |
-
| 43 | -- |
- log = NULL) {
- |
-
| 44 | -- |
- # initialize logging if necessary- |
-
| 45 | -1x | -
- if (base::is.null(log)) {
- |
-
| 46 | -1x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 47 | -- |
- }- |
-
| 48 | -- |
- - |
-
| 49 | -- |
- # For bad records that have timestamps in this data, fill the values with valuBad- |
-
| 50 | -1x | -
- nameColMod <- base::names(data)- |
-
| 51 | -1x | -
- setBad <- data$readout_time %in% timeBad$readout_time- |
-
| 52 | -1x | -
- data[setBad, base::setdiff(nameColMod, 'readout_time')] <- valuBad- |
-
| 53 | -1x | -
- log$debug(- |
-
| 54 | -1x | -
- base::paste0(- |
-
| 55 | -1x | -
- length(setBad),- |
-
| 56 | -1x | -
- ' corrupt records turned to ',- |
-
| 57 | -1x | -
- valuBad- |
-
| 58 | -- |
- )- |
-
| 59 | -- |
- )- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # For missing records, fill with valueBad- |
-
| 62 | -1x | -
- timeAdd <-- |
-
| 63 | -1x | -
- timeBad$readout_time[!(timeBad$readout_time %in% data$readout_time)]- |
-
| 64 | -1x | -
- numAdd <- base::length(timeAdd)- |
-
| 65 | -1x | -
- dfAdd <-- |
-
| 66 | -1x | -
- as.data.frame(base::matrix(valuBad, nrow = numAdd, base::length(nameColMod)))- |
-
| 67 | -1x | -
- base::names(dfAdd) <- nameColMod- |
-
| 68 | -1x | -
- dfAdd$readout_time <- timeAdd- |
-
| 69 | -1x | -
- data <- base::rbind(data, dfAdd)- |
-
| 70 | -1x | -
- data <- data[base::order(data$readout_time), ]- |
-
| 71 | -1x | -
- log$debug(base::paste0(numAdd, ' missing records added'))- |
-
| 72 | -- |
- - |
-
| 73 | -1x | -
- return(data)- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Parse a parquet schema to retrieve data types of table columns- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Get the data types of each data column from a parquet schema.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param schm Schema object of parquet file retrieved from e.g. arrow::read_parquet(...)$schema- |
-
| 11 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 12 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 13 | -- | - - | -
| 14 | -- |
- #' @return A data frame of: \cr- |
-
| 15 | -- |
- #' \code{name} Character. Name of data column
- |
-
| 16 | -- |
- #' \code{type} Characer. Data type
- |
-
| 17 | -- |
- #' \code{nullable} Boolean. Whether the field values are allowed to be null or NA
- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @references Currently none- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @keywords Currently none- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @examples- |
-
| 24 | -- |
- #' # Not run- |
-
| 25 | -- |
- #' # schm <- arrow::read_parquet(file='/path/to/file',as_data_frame=FALSE)$schema- |
-
| 26 | -- |
- #' NEONprocIS.base::def.schm.parq.pars(schm)- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @seealso \link[NEONprocIS.base]{def.read.parq}
- |
-
| 29 | -- |
- #' @seealso \link[NEONprocIS.base]{def.wrte.parq}
- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @export- |
-
| 32 | -- | - - | -
| 33 | -- |
- # changelog and author contributions / copyrights- |
-
| 34 | -- |
- # Cove Sturtevant (2020-04-02)- |
-
| 35 | -- |
- # original creation- |
-
| 36 | -- |
- # Cove Sturtevant (2024-03-20)- |
-
| 37 | -- |
- # add whether the field is nullable- |
-
| 38 | -- |
- ##############################################################################################- |
-
| 39 | -- |
- def.schm.parq.pars <- function(schm, log = NULL) {
- |
-
| 40 | -- |
- # initialize logging if necessary- |
-
| 41 | -15x | -
- if (base::is.null(log)) {
- |
-
| 42 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 43 | -- |
- }- |
-
| 44 | -- |
- - |
-
| 45 | -15x | -
- rpt <-- |
-
| 46 | -15x | -
- base::lapply(- |
-
| 47 | -15x | -
- schm$fields,- |
-
| 48 | -15x | -
- FUN = function(idxFld) {
- |
-
| 49 | -44x | -
- base::data.frame(name = idxFld$name,- |
-
| 50 | -44x | -
- type = idxFld$type$ToString(),- |
-
| 51 | -44x | -
- nullable=idxFld$nullable,- |
-
| 52 | -44x | -
- stringsAsFactors = FALSE)- |
-
| 53 | -- |
- }- |
-
| 54 | -- |
- )- |
-
| 55 | -- |
- - |
-
| 56 | -15x | -
- rpt <- base::do.call(base::rbind,rpt)- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Create output directories- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Create one or more output directories given a starting path and 1 or more relative paths- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param DirBgn String value. Starting path. Defaults to NULL, in which case DirSub contains the full absolute or relative path.- |
-
| 11 | -- |
- #' @param DirSub String value or vector. Path to subdirectories to create relative to starting- |
-
| 12 | -- |
- #' directory- |
-
| 13 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 14 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @return A logical vector, where TRUE indicates the directory at the index was created. FALSE if it was not created for any reason.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @references Currently none- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @keywords Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @examples Currently none- |
-
| 23 | -- |
- #' NEONprocIS.base::def.dir.crea(DirBgn='/scratch/pfs/proc_group/prt',DirSub=c('relative/path/to/new/dir','relative/path2/to/new/dir2')
- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @seealso Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @export- |
-
| 28 | -- | - - | -
| 29 | -- |
- # changelog and author contributions / copyrights- |
-
| 30 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 31 | -- |
- # original creation- |
-
| 32 | -- |
- # Cove Sturtevant (2020-09-06)- |
-
| 33 | -- |
- # fix error when input ~ as the starting path- |
-
| 34 | -- |
- # return TRUE/FALSE for whether directory creation was successful, with better logging- |
-
| 35 | -- |
- ##############################################################################################- |
-
| 36 | -- |
- def.dir.crea <- function(DirBgn=NULL, DirSub, log = NULL) {
- |
-
| 37 | -- |
- # initialize logging if necessary- |
-
| 38 | -5x | -
- if (base::is.null(log)) {
- |
-
| 39 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 40 | -- |
- }- |
-
| 41 | -- |
- - |
-
| 42 | -5x | -
- if (base::is.null(DirBgn) || base::nchar(DirBgn) == 0){
- |
-
| 43 | -2x | -
- dirCrea <- base::paste0(DirSub)- |
-
| 44 | -- |
- } else {
- |
-
| 45 | -3x | -
- dirCrea <- base::paste0(DirBgn, '/', DirSub)- |
-
| 46 | -- |
- }- |
-
| 47 | -- |
- - |
-
| 48 | -5x | -
- rpt <- base::lapply(dirCrea, base::dir.create, recursive = TRUE)- |
-
| 49 | -5x | -
- rpt <- base::unlist(rpt)- |
-
| 50 | -- |
- - |
-
| 51 | -5x | -
- if (base::any(!rpt)){
- |
-
| 52 | -! | -
- log$warn(base::paste0('Did not create directories ', base::paste0(dirCrea[!rpt],collapse = ','),'. This might be because they already exist.'))
- |
-
| 53 | -- |
- }- |
-
| 54 | -5x | -
- if(base::any(rpt)){
- |
-
| 55 | -5x | -
- log$debug(base::paste0('Successfully created directories ', base::paste0(dirCrea[rpt],collapse = ',')))
- |
-
| 56 | -- |
- }- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Generate an error message by constructing the info passed into.- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Mija Choi \email{choim@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Generate a message starting with an error message. These, function which is calling, function called and line number where the error occurred, are appended.- |
-
| 9 | -- |
- #' And return the message- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param Errmsg String. Can be NULL if no specific error.- |
-
| 12 | -- |
- #'- |
-
| 13 | -- |
- #' Requires rlang and utils to run these commands- |
-
| 14 | -- |
- #'- |
-
| 15 | -- |
- #' @param fun_calling. Can get the function name that is calling by the command, rlang::call_frame(n = 2)$fn_name- |
-
| 16 | -- |
- #' @param fun_called. Can get the function name that is called by the command, rlang::call_frame(n = 1)$fn_name- |
-
| 17 | -- |
- #' @param lineNum Number. Can get the line number by the command, getSrcLocation(function() {}, "line")
- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @return Message.- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @references- |
-
| 22 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @keywords Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @examples- |
-
| 27 | -- |
- #' Modify the statement below by replacing "Bad Input" with your own error message and run it.- |
-
| 28 | -- |
- #' msg <- NEONprocIS.base::def.generate.err.msg(errmsg="Bad input", fun_calling=rlang::call_frame(n = 2)$fn_name, fun_called=rlang::call_frame(n = 1)$fn_name, lineNum=getSrcLocation(function() {}, "line"))
- |
-
| 29 | -- |
- #' log$error(msg)- |
-
| 30 | -- |
- #' stop(msg)- |
-
| 31 | -- |
- #' An example output, Error in check(x) : "Bad input" in check near line 4, called by test- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @seealso Currently none- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @export- |
-
| 36 | -- | - - | -
| 37 | -- |
- # changelog and author contributions / copyrights- |
-
| 38 | -- |
- # Mija Choi (2021-08-23)- |
-
| 39 | -- |
- # original creation- |
-
| 40 | -- |
- ##############################################################################################- |
-
| 41 | -- | - - | -
| 42 | -- |
- def.generate.err.msg <- function (errmsg=NULL,- |
-
| 43 | -- |
- fun_calling=NULL,- |
-
| 44 | -- |
- fun_called=NULL,- |
-
| 45 | -- |
- lineNum=NULL){
- |
-
| 46 | -- | - - | -
| 47 | -! | -
- errmsg <- base::paste0("\"",errmsg, "\" in " , fun_called," near line ",lineNum,", called by ", fun_calling)
- |
-
| 48 | -- |
- - |
-
| 49 | -! | -
- return (errmsg)- |
-
| 50 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Convert raw to calibrated data using NEON CVALA polynomial calibration coefficients with new origin F0 for- |
-
| 3 | -- |
- #' Belfort primary precip sensor strain gauges- |
-
| 4 | -- | - - | -
| 5 | -- |
- #' @author- |
-
| 6 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 7 | -- |
- #' David Durden \email{ddurden@battelleecology.org}
- |
-
| 8 | -- | - - | -
| 9 | -- |
- #' @description- |
-
| 10 | -- |
- #' Definition function. Apply NEON calibration polynomial function with calibration coefficients and a new origin F0 for- |
-
| 11 | -- |
- #' Belfort primary precip sensor strain gauges- |
-
| 12 | -- | - - | -
| 13 | -- | - - | -
| 14 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 15 | -- |
- #' @param infoCal A list of calibration information as returned from NEONprocIS.cal::def.read.cal.xml.- |
-
| 16 | -- |
- #' One list element must be \code{cal}, which is a data frame of polynomial calibration coefficients.
- |
-
| 17 | -- |
- #' This data frame must include columns:\cr- |
-
| 18 | -- |
- #' \code{Name} String. The name of the coefficient. Must fit regular expression CVALA[0-9]\cr
- |
-
| 19 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 20 | -- |
- #' Defaults to NULL, in which case converted data will be retured as NA.- |
-
| 21 | -- |
- #' @param varConv A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 22 | -- |
- #' which calibrated output will be computed (all other columns will be ignored). Note that for other- |
-
| 23 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame. Defaults to the first- |
-
| 24 | -- |
- #' column in \code{data}.
- |
-
| 25 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 26 | -- |
- #' NEONprocIS.cal::wrap.cal.conv for what this input is.- |
-
| 27 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 28 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 29 | -- |
- #' created and used within the function.- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @return A Numeric vector of calibrated data\cr- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @references- |
-
| 34 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 35 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @keywords Currently none- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @examples- |
-
| 40 | -- |
- #' data=data.frame(data=c(1,2,3))- |
-
| 41 | -- |
- #' infoCal <- data.frame(Name=c('CVALA1','CVALA2','CVALF0'),Value=c(10,1,5),stringsAsFactors=FALSE)
- |
-
| 42 | -- |
- #' def.cal.conv.poly.aepg600m(data=data,infoCal=infoCal)- |
-
| 43 | -- | - - | -
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 45 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.b}
- |
-
| 46 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.m}
- |
-
| 47 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.cal.conv}
- |
-
| 48 | -- | - - | -
| 49 | -- |
- #' @export- |
-
| 50 | -- | - - | -
| 51 | -- |
- # changelog and author contributions / copyrights- |
-
| 52 | -- |
- # David Durden (2024-02-12)- |
-
| 53 | -- |
- # Original creation- |
-
| 54 | -- | - - | -
| 55 | -- |
- ##############################################################################################- |
-
| 56 | -- |
- def.cal.conv.poly.aepg600m <- function(data = data.frame(data=base::numeric(0)),- |
-
| 57 | -- |
- infoCal = NULL,- |
-
| 58 | -- |
- varConv = base::names(data)[1],- |
-
| 59 | -- |
- calSlct=NULL,- |
-
| 60 | -- |
- log = NULL) {
- |
-
| 61 | -- |
- # Intialize logging if needed- |
-
| 62 | -6x | -
- if (base::is.null(log)) {
- |
-
| 63 | -6x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 64 | -- |
- }- |
-
| 65 | -- | - - | -
| 66 | -- |
- # Ensure input is data frame- |
-
| 67 | -6x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varConv,TestEmpty=FALSE, log = log)- |
-
| 68 | -6x | -
- if (!chk) {
- |
-
| 69 | -1x | -
- stop()- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Check to see if data to be calibrated is a numeric array- |
-
| 73 | -5x | -
- chk <-- |
-
| 74 | -5x | -
- NEONprocIS.base::def.validate.vector(data[[varConv]], TestEmpty = FALSE, TestNumc = TRUE, log = log)- |
-
| 75 | -5x | -
- if (!chk) {
- |
-
| 76 | -! | -
- stop()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # If infoCal is NULL, return NA data- |
-
| 80 | -5x | -
- if (is.null(infoCal)) {
- |
-
| 81 | -1x | -
- log$warn('No calibration information supplied, returning NA values for converted data.')
- |
-
| 82 | -1x | -
- dataConv <- NA * data[[varConv]]- |
-
| 83 | -1x | -
- return(dataConv)- |
-
| 84 | -- |
- } else {
- |
-
| 85 | -- |
- # Check to see if infoCal is a list- |
-
| 86 | -4x | -
- chkList <-- |
-
| 87 | -4x | -
- NEONprocIS.base::def.validate.list(infoCal, log = log)- |
-
| 88 | -4x | -
- if (!chkList) {
- |
-
| 89 | -! | -
- chk <- c(chk, chkList)- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- }- |
-
| 93 | -- | - - | -
| 94 | -- |
- # # Construct the polynomial calibration function- |
-
| 95 | -4x | -
- func <-- |
-
| 96 | -4x | -
- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal, Prfx='CVALA', log = log)- |
-
| 97 | -- | - - | -
| 98 | -- |
- # Convert data using the calibration function- |
-
| 99 | -3x | -
- dpthBckt <- stats::predict(object = func, newdata = data[[varConv]] - as.numeric(infoCal$cal[grep("P0", infoCal$cal$Name),"Value"]))*10 # Total bucket depth (mm)
- |
-
| 100 | -3x | -
- dpthZero <- stats::predict(object = func, as.numeric(infoCal$cal[grep("F0", infoCal$cal$Name),"Value"]) - as.numeric(infoCal$cal[grep("P0", infoCal$cal$Name),"Value"]))*10 # Bucket depth with only oil and antifreeze (i.e. zeroed) (mm)
- |
-
| 101 | -3x | -
- dataConv <- dpthBckt - dpthZero- |
-
| 102 | -- |
- - |
-
| 103 | -3x | -
- return(dataConv)- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Uncertainty for dew/frost point from the relative humidity sensor as part of the relative- |
-
| 3 | -- |
- #' humidity transition- |
-
| 4 | -- | - - | -
| 5 | -- |
- #' @author- |
-
| 6 | -- |
- #' Edward Ayres \email{eayres@battelleecology.org}
- |
-
| 7 | -- | - - | -
| 8 | -- |
- #' @description- |
-
| 9 | -- |
- #' Definition function. Alternative calibration uncertainty function. Create file (dataframe) with- |
-
| 10 | -- |
- #' uncertainty information based off of the L0 temperature, relative humidity, and dew/frost point data values from- |
-
| 11 | -- |
- #' the relative humidity sensor according to NEON.DOC.000851 - NEON Algorithm Theoretical Basis- |
-
| 12 | -- |
- #' Document (ATBD): Humidity and Temperature Sensor.- |
-
| 13 | -- |
- #'- |
-
| 14 | -- |
- #' Accepts L0 data and NEON uncertainty information as produced- |
-
| 15 | -- |
- #' by NEONprocIS.cal::def.read.cal.xml and returns a vector of individual measurement- |
-
| 16 | -- |
- #' uncertainties for each data value.- |
-
| 17 | -- |
- #'- |
-
| 18 | -- |
- #'- |
-
| 19 | -- |
- #' @param data Temperature, relative humidity, and dew/frost point data from the relative humidity sensor- |
-
| 20 | -- |
- #' @param infoCal Not used in this function \cr- |
-
| 21 | -- |
- #' @param varUcrt A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 22 | -- |
- #' which uncertainty data will be computed (dew_point in this function).- |
-
| 23 | -- |
- #' @param calSlct Defaults to NULL. See the inputs to NEONprocIS.cal::wrap.ucrt.dp0p for what this input is.- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 26 | -- |
- #' created and used within the function.- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @return A data frame with the following variables:\cr- |
-
| 29 | -- |
- #' \code{ucrtMeas_dew_point} - combined measurement uncertainty for an individual dew/frost point reading. Includes the
- |
-
| 30 | -- |
- #' repeatability and reproducibility of the sensor and the lab DAS and uncertainty of the- |
-
| 31 | -- |
- #' calibration procedures and coefficients including uncertainty in the standard (truth).- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @references- |
-
| 34 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 35 | -- |
- #' NEON.DOC.000785 TIS Level 1 Data products Uncertainty Budget Estimation Plan- |
-
| 36 | -- |
- #' NEON.DOC.000746 Calibration Fixture and Sensor Uncertainty Analysis: CVAL 2014 Uncertainty Manual- |
-
| 37 | -- |
- #' NEON.DOC.000851 NEON Algorithm Theoretical Basis Document (ATBD): Humidity and Temperature Sensor- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @keywords calibration, uncertainty, L0', hmp155, dew point, frost point- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @examples- |
-
| 42 | -- |
- #' data <- data.frame(dew_point=c(1,-1,5,4,4.5),temperature=c(2,3,6,8,5),relative_humidity=c(1,6,7,0,10),- |
-
| 43 | -- |
- #' readout_time=as.POSIXct(c('2019-01-01 02:00','2019-01-01 04:01','2019-01-01 06:02','2019-01-01 08:01','2019-01-01 10:02'),tz='GMT'))
- |
-
| 44 | -- | - - | -
| 45 | -- |
- #' calSlct=list("temperature"= data.frame(timeBgn=as.POSIXct("2019-01-01",tz="GMT"),
- |
-
| 46 | -- |
- #' timeEnd=as.POSIXct("2019-01-02",tz="GMT"),file = "30000000000080_WO29705_157555.xml",id = 157555, expi= FALSE),
- |
-
| 47 | -- |
- #' "relative_humidity"= data.frame(timeBgn=as.POSIXct("2019-01-01",tz="GMT"),
- |
-
| 48 | -- |
- #' timeEnd=as.POSIXct("2019-01-02",tz="GMT"),file = "30000000000080_WO29705_157554.xml",id = 157554, expi= FALSE),
- |
-
| 49 | -- |
- #' "dew_point"= data.frame(timeBgn=as.POSIXct("2019-01-01",tz="GMT"),timeEnd=as.POSIXct("2019-01-02",tz="GMT"),
- |
-
| 50 | -- |
- #' file = "30000000000080_WO29705_157556.xml",id = 157556, expi= FALSE))- |
-
| 51 | -- | - - | -
| 52 | -- |
- #' def.ucrt.meas.rh.dew.frst.pt(data=data,calSlct=calSlct)- |
-
| 53 | -- | - - | -
| 54 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 55 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.rstc.poly}
- |
-
| 56 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.volt.poly}
- |
-
| 57 | -- |
- #' @seealso \link[NEONprocIS.base]{def.log.init}
- |
-
| 58 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.ucrt.dp0p}
- |
-
| 59 | -- | - - | -
| 60 | -- |
- #' @export- |
-
| 61 | -- | - - | -
| 62 | -- |
- # changelog and author contributions / copyrights- |
-
| 63 | -- |
- # Edward Ayres (2020-10-07)- |
-
| 64 | -- |
- # original creation- |
-
| 65 | -- |
- # Mija Choi (2021-02-26)- |
-
| 66 | -- |
- # change an input param, varUcrt, from names(data)[1] to "dew_point"- |
-
| 67 | -- |
- # modify the comments of data under examples above- |
-
| 68 | -- |
- # by adding readout_time, adding dew_point and removing dew_pont at the end- |
-
| 69 | -- |
- # Edward Ayres (2021-04-29)- |
-
| 70 | -- |
- # Added partial uncertainty of individual dew/frost point temperature measurements with respect to ambient- |
-
| 71 | -- |
- # temperature and relative humidity for Level 1 Mean uncertainty calculations- |
-
| 72 | -- |
- # Cove Sturtevant (2022-08-24)- |
-
| 73 | -- |
- # Corrected virtual temperature equation when above freezing (missing exponents)- |
-
| 74 | -- |
- ##############################################################################################- |
-
| 75 | -- |
- def.ucrt.meas.rh.dew.frst.pt <- function(data = data.frame(data=base::numeric(0)),- |
-
| 76 | -- |
- infoCal = NULL,- |
-
| 77 | -- |
- varUcrt = "dew_point",- |
-
| 78 | -- |
- calSlct=NULL,- |
-
| 79 | -- |
- log = NULL) {
- |
-
| 80 | -- |
- # Initialize logging if necessary- |
-
| 81 | -11x | -
- if (base::is.null(log)) {
- |
-
| 82 | -11x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # Ensure input is data frame with the target variable in it- |
-
| 86 | -11x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=c('readout_time',varUcrt),TestEmpty=FALSE, log = log)
- |
-
| 87 | -11x | -
- if (!chk) {
- |
-
| 88 | -1x | -
- stop()- |
-
| 89 | -- |
- }- |
-
| 90 | -- |
- - |
-
| 91 | -- |
- # Check data input is numeric- |
-
| 92 | -10x | -
- if (!NEONprocIS.base::def.validate.vector(data[[varUcrt]],TestEmpty = FALSE, TestNumc = TRUE, log=log)) {
- |
-
| 93 | -1x | -
- stop()- |
-
| 94 | -- |
- }- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- # Basic starting info- |
-
| 97 | -9x | -
- timeMeas <- data$readout_time- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- # Initialize output data frame- |
-
| 100 | -9x | -
- dataUcrt <- data[[varUcrt]] # Target variable to compute uncertainty for- |
-
| 101 | -9x | -
- ucrt <- base::data.frame(ucrtMeas = NA * dataUcrt, ucrt_dfpt_t_L1 = NA * dataUcrt, ucrt_dfpt_rh_L1 = NA * dataUcrt)- |
-
| 102 | -- |
- - |
-
| 103 | -- |
- # Specify constants based on relative humidity ATBD- |
-
| 104 | -9x | -
- absZero <- -273.15 # (degrees C)- |
-
| 105 | -9x | -
- b0 <- -0.58002206*10^4- |
-
| 106 | -9x | -
- b1 <- 1.3914993- |
-
| 107 | -9x | -
- b2 <- -0.048640239- |
-
| 108 | -9x | -
- b3 <- 0.41764768 * 10^-4- |
-
| 109 | -9x | -
- b4 <- -0.14452093 * 10^-7- |
-
| 110 | -9x | -
- b5 <- 6.5459673- |
-
| 111 | -9x | -
- c0 <- 0.4931358- |
-
| 112 | -9x | -
- c1 <- -0.46094296 * 10^-2- |
-
| 113 | -9x | -
- c2 <- 0.13746454 * 10^-4- |
-
| 114 | -9x | -
- c3 <- -0.12743214 * 10^-7- |
-
| 115 | -9x | -
- a0 <- -0.56745359 * 10^4- |
-
| 116 | -9x | -
- a1 <- 6.3925247- |
-
| 117 | -9x | -
- a2 <- -0.96778430 * 10^-2- |
-
| 118 | -9x | -
- a3 <- 0.62215701 * 10^-6- |
-
| 119 | -9x | -
- a4 <- 0.20747825 * 10^-8- |
-
| 120 | -9x | -
- a5 <- -0.94840240 * 10^-12- |
-
| 121 | -9x | -
- a6 <- 4.1635019- |
-
| 122 | -- |
- - |
-
| 123 | -- |
- # Calculate saturation vapor pressure- |
-
| 124 | -9x | -
- data$virtual_temperature <- NA*data$temperature- |
-
| 125 | -9x | -
- data$saturation_vapor_pressure <- data$virtual_temperature- |
-
| 126 | -9x | -
- data$derivative_dfpt_t_part1 <- data$virtual_temperature- |
-
| 127 | -9x | -
- data$derivative_dfpt_t_part2 <- data$virtual_temperature- |
-
| 128 | -- |
- # Identify rows with temperature above 0 degrees C- |
-
| 129 | -9x | -
- waterRows <- which(data$temperature > 0)- |
-
| 130 | -9x | -
- if(length(waterRows)>0){
- |
-
| 131 | -- |
- # Calculate virtual temperature at temperatures above 0 degrees C- |
-
| 132 | -9x | -
- data$virtual_temperature[waterRows] <- ((data$temperature[waterRows]-absZero)-- |
-
| 133 | -9x | -
- (c0*(data$temperature[waterRows]-absZero)^0+- |
-
| 134 | -9x | -
- c1*(data$temperature[waterRows]-absZero)^1+- |
-
| 135 | -9x | -
- c2*(data$temperature[waterRows]-absZero)^2+- |
-
| 136 | -9x | -
- c3*(data$temperature[waterRows]-absZero)^3) )- |
-
| 137 | -- |
- - |
-
| 138 | -- |
- # Calculate saturation vapor pressure over water- |
-
| 139 | -9x | -
- data$saturation_vapor_pressure[waterRows] <- exp((b0/data$virtual_temperature[waterRows])+- |
-
| 140 | -9x | -
- (data$virtual_temperature[waterRows]^0*b1+- |
-
| 141 | -9x | -
- data$virtual_temperature[waterRows]^1*b2+- |
-
| 142 | -9x | -
- data$virtual_temperature[waterRows]^2*b3+- |
-
| 143 | -9x | -
- data$virtual_temperature[waterRows]^3*b4)+- |
-
| 144 | -9x | -
- log(data$virtual_temperature[waterRows])*b5)/100- |
-
| 145 | -- |
- }- |
-
| 146 | -- |
- # Identify rows with temperature above 0 degrees C- |
-
| 147 | -9x | -
- iceRows <- which(data$temperature <= 0)- |
-
| 148 | -9x | -
- if(length(iceRows>0)){
- |
-
| 149 | -- |
- # Calculate virtual temperature at temperatures at or below 0 degrees C- |
-
| 150 | -8x | -
- data$virtual_temperature[iceRows] <- data$temperature[iceRows]-absZero- |
-
| 151 | -- |
- - |
-
| 152 | -- |
- # Calculate saturation vapor pressure over ice- |
-
| 153 | -8x | -
- data$saturation_vapor_pressure[iceRows] <- exp((a0/data$virtual_temperature[iceRows])+- |
-
| 154 | -8x | -
- (data$virtual_temperature[iceRows]^0*a1+- |
-
| 155 | -8x | -
- data$virtual_temperature[iceRows]^1*a2+- |
-
| 156 | -8x | -
- data$virtual_temperature[iceRows]^2*a3+- |
-
| 157 | -8x | -
- data$virtual_temperature[iceRows]^3*a4+- |
-
| 158 | -8x | -
- data$virtual_temperature[iceRows]^4*a5)+- |
-
| 159 | -8x | -
- log(data$virtual_temperature[iceRows])*a6)/100- |
-
| 160 | -- |
- }- |
-
| 161 | -- |
- - |
-
| 162 | -- |
- # Calculate partial derivative (degrees C hPa-1) of ATBD Eq. 1, substituting Eq. 3 for P_pw and Eq. 5 for P_pi, with respect to P_ws_w/i- |
-
| 163 | -9x | -
- data$derivative_dfpt_t_part1 <- 4719.72/(data$saturation_vapor_pressure*(log10(data$saturation_vapor_pressure*data$relative_humidity)-30.605)^2 )- |
-
| 164 | -- |
- - |
-
| 165 | -- |
- # Calculate derivative (hpa K-1) of ATBD Eq.3 or 5, substituting Eq. 4 or 6 for virtual temperature, with respect to temperature- |
-
| 166 | -- |
- # Do this for temperatures >273.15 K- |
-
| 167 | -9x | -
- if(length(waterRows)>0){
- |
-
| 168 | -9x | -
- data$derivative_dfpt_t_part2[waterRows] <- 1/100*- |
-
| 169 | -9x | -
- (1-(0*c0*(data$temperature[waterRows]-absZero)^-1+- |
-
| 170 | -9x | -
- 1*c1*(data$temperature[waterRows]-absZero)^0+- |
-
| 171 | -9x | -
- 2*c2*(data$temperature[waterRows]-absZero)^1+- |
-
| 172 | -9x | -
- 3*c3*(data$temperature[waterRows]-absZero)^2))*- |
-
| 173 | -9x | -
- (-(b0/data$virtual_temperature[waterRows]^2)+- |
-
| 174 | -9x | -
- 1*b2*data$virtual_temperature[waterRows]^0+- |
-
| 175 | -9x | -
- 2*b3*data$virtual_temperature[waterRows]^1+- |
-
| 176 | -9x | -
- 3*b4*data$virtual_temperature[waterRows]^2+- |
-
| 177 | -9x | -
- b5/data$virtual_temperature[waterRows])*- |
-
| 178 | -9x | -
- (exp((b0/data$virtual_temperature[waterRows])+- |
-
| 179 | -9x | -
- b1*data$virtual_temperature[waterRows]^0+- |
-
| 180 | -9x | -
- b2*data$virtual_temperature[waterRows]^1+- |
-
| 181 | -9x | -
- b3*data$virtual_temperature[waterRows]^2+- |
-
| 182 | -9x | -
- b4*data$virtual_temperature[waterRows]^3+- |
-
| 183 | -9x | -
- b5*log(data$virtual_temperature[waterRows])))- |
-
| 184 | -- |
- }- |
-
| 185 | -- |
- # Do this for temperatures <=273.15 K- |
-
| 186 | -9x | -
- if(length(iceRows)>0){
- |
-
| 187 | -8x | -
- data$derivative_dfpt_t_part2[iceRows] <- 1/100*- |
-
| 188 | -8x | -
- ((-a0/(data$temperature[iceRows]-absZero)^2+- |
-
| 189 | -8x | -
- a2+- |
-
| 190 | -8x | -
- 2*a3*(data$temperature[iceRows]-absZero)+- |
-
| 191 | -8x | -
- 3*a4*(data$temperature[iceRows]-absZero)^2+- |
-
| 192 | -8x | -
- 4*a5*(data$temperature[iceRows]-absZero)^3+- |
-
| 193 | -8x | -
- (a6/(data$temperature[iceRows]-absZero)))*- |
-
| 194 | -8x | -
- exp(a0/(data$temperature[iceRows]-absZero)+- |
-
| 195 | -8x | -
- a1*(data$temperature[iceRows]-absZero)^0+- |
-
| 196 | -8x | -
- a2*(data$temperature[iceRows]-absZero)^1+- |
-
| 197 | -8x | -
- a3*(data$temperature[iceRows]-absZero)^2+- |
-
| 198 | -8x | -
- a4*(data$temperature[iceRows]-absZero)^3+- |
-
| 199 | -8x | -
- a5*(data$temperature[iceRows]-absZero)^4+- |
-
| 200 | -8x | -
- a6*log(data$temperature[iceRows]-absZero)))- |
-
| 201 | -- |
- }- |
-
| 202 | -- |
- - |
-
| 203 | -- |
- # Calculate derivative of dew/frost point with respect to temperature (K)- |
-
| 204 | -9x | -
- data$derivative_dfpt_t <- data$derivative_dfpt_t_part1*data$derivative_dfpt_t_part2- |
-
| 205 | -- |
- - |
-
| 206 | -- |
- - |
-
| 207 | -- |
- - |
-
| 208 | -- |
- # Roll through the temperature and RH calibration files, applying the computations for the applicable time period(s)- |
-
| 209 | -9x | -
- calSlctTemp <- calSlct$temperature- |
-
| 210 | -9x | -
- for(idxRowTemp in base::seq_len(base::nrow(calSlctTemp))){
- |
-
| 211 | -- |
- - |
-
| 212 | -- |
- # What points in the output correspond to this row?- |
-
| 213 | -9x | -
- setCalTemp <- timeMeas >= calSlctTemp$timeBgn[idxRowTemp] & timeMeas < calSlctTemp$timeEnd[idxRowTemp]- |
-
| 214 | -- |
- - |
-
| 215 | -- |
- # Move on if no data points fall within this cal window- |
-
| 216 | -9x | -
- if(base::sum(setCalTemp) == 0){
- |
-
| 217 | -1x | -
- next- |
-
| 218 | -- |
- }- |
-
| 219 | -- |
- - |
-
| 220 | -- |
- # If a calibration file is available for this period, open it and get calibration information- |
-
| 221 | -- |
- - |
-
| 222 | -8x | -
- fileCal <- base::paste0(calSlctTemp$path[idxRowTemp],calSlctTemp$file[idxRowTemp])- |
-
| 223 | -8x | -
- fileCal_Chk <- try(NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE),silent = TRUE)- |
-
| 224 | -- |
- - |
-
| 225 | -8x | -
- if(!(class(fileCal_Chk)[1] == "try-error")){
- |
-
| 226 | -7x | -
- infoCalTemp <- NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE)- |
-
| 227 | -- |
- } else {
- |
-
| 228 | -1x | -
- log$debug('No temperature calibration information supplied for at least a period of the data, returning NA values for individual measurement uncertainty during that interval.')
- |
-
| 229 | -1x | -
- next- |
-
| 230 | -- |
- }- |
-
| 231 | -- |
- - |
-
| 232 | -- |
- - |
-
| 233 | -- |
- # Check format of infoCalTemp- |
-
| 234 | -7x | -
- if (!NEONprocIS.cal::def.validate.info.cal(infoCalTemp,CoefUcrt='U_CVALA1',log=log)){
- |
-
| 235 | -1x | -
- stop()- |
-
| 236 | -- |
- }- |
-
| 237 | -- |
- - |
-
| 238 | -- |
- - |
-
| 239 | -- |
- # Now roll through the relative humidity calibrations, applying the computations for the applicable time period(s)- |
-
| 240 | -6x | -
- calSlctRh <- calSlct$relative_humidity- |
-
| 241 | -6x | -
- for(idxRowRh in base::seq_len(base::nrow(calSlctRh))){
- |
-
| 242 | -- |
- - |
-
| 243 | -- |
- # What points in the output correspond to this row?- |
-
| 244 | -6x | -
- setCalRh <- timeMeas >= calSlctRh$timeBgn[idxRowRh] & timeMeas < calSlctRh$timeEnd[idxRowRh]- |
-
| 245 | -- |
- - |
-
| 246 | -- |
- # Merge with setCalTemp to find the data points applicable to both the temp and RH calibration files- |
-
| 247 | -6x | -
- setCal <- setCalTemp & setCalRh- |
-
| 248 | -- |
- - |
-
| 249 | -- |
- # Move on if no data points fall within this joint cal window- |
-
| 250 | -6x | -
- if(base::sum(setCal) == 0){
- |
-
| 251 | -1x | -
- next- |
-
| 252 | -- |
- }- |
-
| 253 | -- |
- - |
-
| 254 | -- |
- # If a calibration file is available for this period, open it and get calibration information- |
-
| 255 | -5x | -
- fileCal <- base::paste0(calSlctRh$path[idxRowRh],calSlctRh$file[idxRowRh])- |
-
| 256 | -5x | -
- fileCal_Chk <- try(NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE),silent = TRUE)- |
-
| 257 | -- |
- - |
-
| 258 | -5x | -
- if(!(class(fileCal_Chk)[1] == "try-error")){
- |
-
| 259 | -4x | -
- infoCalRh <- NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE)- |
-
| 260 | -- |
- } else {
- |
-
| 261 | -1x | -
- log$debug('No relative humidity calibration information supplied for at least a period of the data, returning NA values for individual measurement uncertainty during that interval.')
- |
-
| 262 | -1x | -
- next- |
-
| 263 | -- |
- }- |
-
| 264 | -- |
- - |
-
| 265 | -- |
- # Check format of infoCalRh- |
-
| 266 | -4x | -
- if (!NEONprocIS.cal::def.validate.info.cal(infoCal = infoCalRh,CoefUcrt='U_CVALA1',log=log)){
- |
-
| 267 | -1x | -
- stop()- |
-
| 268 | -- |
- }- |
-
| 269 | -- |
- - |
-
| 270 | -- |
- # Uncertainty coefficient U_CVALA1 represents the combined measurement uncertainty for an- |
-
| 271 | -- |
- # individual reading. It includes the repeatability and reproducibility of the sensor and the- |
-
| 272 | -- |
- # lab DAS and ii) uncertainty of the calibration procedures and coefficients including- |
-
| 273 | -- |
- # uncertainty in the standard (truth).- |
-
| 274 | -- |
- # Get the uncertainty coefficients for temperature and relative humidity- |
-
| 275 | -3x | -
- ucrtCoefTemp <- infoCalTemp$ucrt[infoCalTemp$ucrt$Name == 'U_CVALA1',]- |
-
| 276 | -3x | -
- ucrtCoefRh <- infoCalRh$ucrt[infoCalRh$ucrt$Name == 'U_CVALA1',]- |
-
| 277 | -- |
- - |
-
| 278 | -- |
- # Issue warning if more than one matching uncertainty coefficient was found- |
-
| 279 | -3x | -
- if(base::nrow(ucrtCoefTemp) > 1){
- |
-
| 280 | -1x | -
- log$warn("More than one matching uncertainty coefficient was found for temperature U_CVALA1. Using the first.")
- |
-
| 281 | -- |
- }- |
-
| 282 | -3x | -
- if(base::nrow(ucrtCoefRh) > 1){
- |
-
| 283 | -1x | -
- log$warn("More than one matching uncertainty coefficient was found for relative humidity U_CVALA1. Using the first.")
- |
-
| 284 | -- |
- }- |
-
| 285 | -- |
- - |
-
| 286 | -- |
- # Calculate partial uncertainty (degrees C) of individual dew/frost point temperature measurements with respect to ambient temperature- |
-
| 287 | -3x | -
- ucrt_dfpt_t <- abs(data$derivative_dfpt_t[setCal])*base::as.numeric(ucrtCoefTemp$Value[1])- |
-
| 288 | -- |
- - |
-
| 289 | -- |
- # Calculate partial uncertainty (degrees C) of individual dew/frost point temperature measurements with respect to ambient relative humidity- |
-
| 290 | -3x | -
- ucrt_dfpt_rh <- abs(4719.72/(data$relative_humidity[setCal]*(log10(data$saturation_vapor_pressure[setCal]*data$relative_humidity[setCal])-30.605)^2 ))*base::as.numeric(ucrtCoefRh$Value[1])- |
-
| 291 | -- |
- - |
-
| 292 | -- |
- # Calculate the combined uncertainty for each dew/frost point measurement- |
-
| 293 | -3x | -
- ucrt$ucrtMeas[setCal] <- sqrt((ucrt_dfpt_t^2)+(ucrt_dfpt_rh^2))- |
-
| 294 | -- |
- - |
-
| 295 | -- |
- - |
-
| 296 | -- |
- - |
-
| 297 | -- | - - | -
| 298 | -- |
- # Get the uncertainty coefficients for temperature and relative humidity that are needed to calculate the uncertainty of the L1 Mean data product- |
-
| 299 | -3x | -
- ucrtCoefTempUa3 <- infoCalTemp$ucrt[infoCalTemp$ucrt$Name == 'U_CVALA3',]- |
-
| 300 | -3x | -
- ucrtCoefRhUa3 <- infoCalRh$ucrt[infoCalRh$ucrt$Name == 'U_CVALA3',]- |
-
| 301 | -- |
- - |
-
| 302 | -- |
- # Issue warning if more than one matching uncertainty coefficient was found- |
-
| 303 | -3x | -
- if(base::nrow(ucrtCoefTempUa3) > 1){
- |
-
| 304 | -! | -
- log$warn("More than one matching uncertainty coefficient was found for temperature U_CVALA3. Using the first.")
- |
-
| 305 | -- |
- }- |
-
| 306 | -3x | -
- if(base::nrow(ucrtCoefRhUa3) > 1){
- |
-
| 307 | -! | -
- log$warn("More than one matching uncertainty coefficient was found for relative humidity U_CVALA3. Using the first.")
- |
-
| 308 | -- |
- }- |
-
| 309 | -- |
- - |
-
| 310 | -- |
- # Calculate partial uncertainty (degrees C) of individual dew/frost point temperature measurements with respect to ambient temperature for Level 1 Mean uncertainty calculations- |
-
| 311 | -3x | -
- ucrt$ucrt_dfpt_t_L1[setCal] <- abs(data$derivative_dfpt_t[setCal])*base::as.numeric(ucrtCoefTempUa3$Value[1])- |
-
| 312 | -- |
- - |
-
| 313 | -- |
- # Calculate partial uncertainty (degrees C) of individual dew/frost point temperature measurements with respect to ambient relative humidity for Level 1 Mean uncertainty calculations- |
-
| 314 | -3x | -
- ucrt$ucrt_dfpt_rh_L1[setCal] <- abs(4719.72/(data$relative_humidity[setCal]*(log10(data$saturation_vapor_pressure[setCal]*data$relative_humidity[setCal])-30.605)^2 ))*base::as.numeric(ucrtCoefRhUa3$Value[1])- |
-
| 315 | -- |
- - |
-
| 316 | -- |
- - |
-
| 317 | -- |
- } # End loop around RH calibration files- |
-
| 318 | -- |
- - |
-
| 319 | -- |
- } # End loop around Temperature calibration files- |
-
| 320 | -- |
- - |
-
| 321 | -- |
- - |
-
| 322 | -7x | -
- return(ucrt)- |
-
| 323 | -- |
- - |
-
| 324 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Convert raw to calibrated data using NEON polynomial calibration coefficients that are split based on input range- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Nora Catolico \email{ncatolico@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Apply NEON calibration polynomial function contained in coefficients- |
-
| 9 | -- |
- #' CVALM0, CVALM1, CVALM2, CVALH0, CVALH1, CVALH2 etc. to convert raw data to calibrated data.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 12 | -- |
- #' @param infoCal A list of calibration information as returned from NEONprocIS.cal::def.read.cal.xml.- |
-
| 13 | -- |
- #' One list element must be \code{cal}, which is a data frame of polynomial calibration coefficients.
- |
-
| 14 | -- |
- #' This data frame must include columns:\cr- |
-
| 15 | -- |
- #' \code{Name} String. The name of the coefficient. Must fit regular expression CVALM[0-9]\cr
- |
-
| 16 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 17 | -- |
- #' Defaults to NULL, in which case converted data will be retured as NA.- |
-
| 18 | -- |
- #' @param varConv A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 19 | -- |
- #' which the calibration will be applied (all other columns will be ignored). Note that for other- |
-
| 20 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame. Defaults to the first- |
-
| 21 | -- |
- #' column in \code{data}.
- |
-
| 22 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 23 | -- |
- #' NEONprocIS.cal::wrap.cal.conv for what this input is.- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 26 | -- |
- #' created and used within the function.- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @return A Numeric vector of calibrated data\cr- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @references- |
-
| 31 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 32 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @keywords Currently none- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @examples- |
-
| 37 | -- |
- #' data=data.frame(data=c(1,2,3))- |
-
| 38 | -- |
- #' infoCal <- list(cal=data.frame(Name=c('CVALH0','CVALH1','CVALH2','CVALM0','CVALM1','CVALM2'),Value=c(-0.48,0.97,-0.000001,0.11,1,-0.00024),stringsAsFactors=FALSE))
- |
-
| 39 | -- |
- #' def.cal.conv.poly.split(data=data,infoCal=infoCal)- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 42 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly}
- |
-
| 43 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.b}
- |
-
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.cal.conv}
- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @export- |
-
| 47 | -- | - - | -
| 48 | -- |
- # changelog and author contributions / copyrights- |
-
| 49 | -- |
- # Nora Catolico (2023-03-02)- |
-
| 50 | -- |
- # original creation, from def.cal.conv.poly.m by Cove Sturtevant- |
-
| 51 | -- |
- #- |
-
| 52 | -- |
- ##############################################################################################- |
-
| 53 | -- |
- def.cal.conv.poly.split <- function(data = data.frame(data=base::numeric(0)),- |
-
| 54 | -- |
- infoCal = NULL,- |
-
| 55 | -- |
- varConv = base::names(data)[1],- |
-
| 56 | -- |
- calSlct=NULL,- |
-
| 57 | -- |
- log = NULL) {
- |
-
| 58 | -- |
- # Intialize logging if needed- |
-
| 59 | -2x | -
- if (base::is.null(log)) {
- |
-
| 60 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 61 | -- |
- }- |
-
| 62 | -- | - - | -
| 63 | -- |
- # Ensure input is data frame- |
-
| 64 | -2x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varConv,TestEmpty=FALSE, log = log)- |
-
| 65 | -2x | -
- if (!chk) {
- |
-
| 66 | -! | -
- stop()- |
-
| 67 | -- |
- }- |
-
| 68 | -- |
- - |
-
| 69 | -- |
- # Check to see if data to be calibrated is a numeric array- |
-
| 70 | -2x | -
- chk <-- |
-
| 71 | -2x | -
- NEONprocIS.base::def.validate.vector(data[[varConv]], TestEmpty = FALSE, TestNumc = TRUE, log = log)- |
-
| 72 | -2x | -
- if (!chk) {
- |
-
| 73 | -! | -
- stop()- |
-
| 74 | -- |
- }- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # If infoCal is NULL, return NA data- |
-
| 77 | -2x | -
- if (is.null(infoCal)) {
- |
-
| 78 | -1x | -
- log$warn('No calibration information supplied, returning NA values for converted data.')
- |
-
| 79 | -1x | -
- dataConv <- NA * data[[varConv]]- |
-
| 80 | -1x | -
- return(dataConv)- |
-
| 81 | -- |
- } else {
- |
-
| 82 | -- |
- # Check to see if infoCal is a list- |
-
| 83 | -1x | -
- chkList <-- |
-
| 84 | -1x | -
- NEONprocIS.base::def.validate.list(infoCal, log = log)- |
-
| 85 | -1x | -
- if (!chkList) {
- |
-
| 86 | -! | -
- chk <- c(chk, chkList)- |
-
| 87 | -- |
- }- |
-
| 88 | -- |
- - |
-
| 89 | -- |
- }- |
-
| 90 | -- | - - | -
| 91 | -- |
- # Construct the polynomial calibration function- |
-
| 92 | -1x | -
- func1 <-- |
-
| 93 | -1x | -
- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal, Prfx='CVALH', log = log)- |
-
| 94 | -1x | -
- func2 <-- |
-
| 95 | -1x | -
- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal, Prfx='CVALM', log = log)- |
-
| 96 | -- |
- - |
-
| 97 | -- |
- # Convert data using the calibration function based on range- |
-
| 98 | -1x | -
- dataRaw <- data[[varConv]]- |
-
| 99 | -1x | -
- dataConv <- NA * dataRaw- |
-
| 100 | -1x | -
- setFunc01 <- !base::is.na(dataRaw) & dataRaw > 100- |
-
| 101 | -1x | -
- dataConv[setFunc01] <- stats::predict(object = func1, newdata = dataRaw[setFunc01])- |
-
| 102 | -1x | -
- setFunc02 <- !base::is.na(dataRaw) & dataRaw <= 100- |
-
| 103 | -1x | -
- dataConv[setFunc02] <- stats::predict(object = func2, newdata = dataRaw[setFunc02])- |
-
| 104 | -- |
- - |
-
| 105 | -1x | -
- return(dataConv)- |
-
| 106 | -- |
- - |
-
| 107 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compile metadata for calibrations- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in any number of calibration files and compile their metadata, including- |
-
| 9 | -- |
- #' file name, certificate number, and valid date range valid date range.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param fileCal Character vector of the full or relative paths to each calibration file- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @return A data frame of calibration metadata- |
-
| 16 | -- | - - | -
| 17 | -- |
- #' @references- |
-
| 18 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 19 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @keywords Currently none- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @examples- |
-
| 24 | -- |
- #' # Not run- |
-
| 25 | -- |
- #' # fileCal <- c('/path/to/file1.xml','/path/to/file2.xml')
- |
-
| 26 | -- |
- #' # metaCal <- NEONprocIS.cal::def.cal.meta(fileCal=fileCal)- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 29 | -- |
- #'- |
-
| 30 | -- |
- #' @export- |
-
| 31 | -- | - - | -
| 32 | -- |
- # changelog and author contributions / copyrights- |
-
| 33 | -- |
- # Cove Sturtevant (2020-02-04)- |
-
| 34 | -- |
- # original creation- |
-
| 35 | -- |
- # Cove Sturtevant (2020-12-08)- |
-
| 36 | -- |
- # added path to calibration directory in output- |
-
| 37 | -- |
- # Cove Sturtevant (2021-04-15)- |
-
| 38 | -- |
- # added stream ID to the output- |
-
| 39 | -- |
- # Cove Sturtevant (2025-05-01)- |
-
| 40 | -- |
- # don't stop execution when individual files fail.- |
-
| 41 | -- |
- # Instead, output error status for each file.- |
-
| 42 | -- |
- ##############################################################################################- |
-
| 43 | -- |
- def.cal.meta <- function(fileCal, log = NULL) {
- |
-
| 44 | -- |
- # Intialize logging if needed- |
-
| 45 | -22x | -
- if (base::is.null(log)) {
- |
-
| 46 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 47 | -- |
- }- |
-
| 48 | -- |
- - |
-
| 49 | -22x | -
- numCal <- base::length(fileCal)- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # Get the filenames of the calibration files without path information- |
-
| 52 | -22x | -
- fileCalSplt <- strsplit(fileCal,'/')- |
-
| 53 | -22x | -
- nameFileCal <- base::unlist(base::lapply(fileCalSplt,utils::tail,n=1))- |
-
| 54 | -22x | -
- pathFileCal <- base::unlist(base::lapply(fileCalSplt,FUN=function(idxFileCalSplt){
- |
-
| 55 | -- |
- - |
-
| 56 | -67x | -
- if(base::length(idxFileCalSplt) > 1){
- |
-
| 57 | -67x | -
- pathIdx <- base::paste0(- |
-
| 58 | -67x | -
- c(utils::head(idxFileCalSplt,n=-1),''),- |
-
| 59 | -67x | -
- collapse='/'- |
-
| 60 | -- |
- )- |
-
| 61 | -- |
- } else {
- |
-
| 62 | -! | -
- pathIdx <- ""- |
-
| 63 | -- |
- }- |
-
| 64 | -- | - - | -
| 65 | -- |
- }))- |
-
| 66 | -- |
- - |
-
| 67 | -- |
- # intialize output- |
-
| 68 | -22x | -
- metaCal <- base::vector(mode = "list", length = numCal)- |
-
| 69 | -- |
- - |
-
| 70 | -- |
- # Retrieve metadata for each calibration file- |
-
| 71 | -22x | -
- for (idxFileCal in base::seq_len(numCal)){
- |
-
| 72 | -- |
- - |
-
| 73 | -- |
- # Read in the cal- |
-
| 74 | -67x | -
- infoCal <- try(NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal[idxFileCal],Vrbs=TRUE,log=log),silent=FALSE)- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Error check- |
-
| 77 | -67x | -
- if(!NEONprocIS.cal::def.validate.info.cal(infoCal,NameList=c('cal','ucrt','file','timeVali'),log=log)){
- |
-
| 78 | -- |
- - |
-
| 79 | -1x | -
- log$error(paste0('Error pulling data from calibration file ',fileCal[idxFileCal],' . Some or all metadata will be NA.'))
- |
-
| 80 | -1x | -
- if(!("list" %in% base::class(infoCal))){
- |
-
| 81 | -1x | -
- infoCal <- base::list()- |
-
| 82 | -- |
- }- |
-
| 83 | -1x | -
- if(base::is.null(infoCal$timeVali$StartTime)){
- |
-
| 84 | -1x | -
- infoCal$timeVali$StartTime <- as.POSIXct(NA)- |
-
| 85 | -- |
- }- |
-
| 86 | -1x | -
- if(base::is.null(infoCal$timeVali$EndTime)){
- |
-
| 87 | -1x | -
- infoCal$timeVali$EndTime <- as.POSIXct(NA)- |
-
| 88 | -- |
- }- |
-
| 89 | -1x | -
- if(base::is.null(infoCal$file$StreamCalVal$CertificateNumber)){
- |
-
| 90 | -1x | -
- infoCal$file$StreamCalVal$CertificateNumber <- NA- |
-
| 91 | -- |
- }- |
-
| 92 | -1x | -
- if(base::is.null(infoCal$file$StreamCalVal$StreamID)){
- |
-
| 93 | -1x | -
- infoCal$file$StreamCalVal$StreamID <- NA- |
-
| 94 | -- |
- }- |
-
| 95 | -1x | -
- infoCal$err <- TRUE- |
-
| 96 | -- |
- - |
-
| 97 | -66x | -
- } else if (base::is.null(infoCal$file$StreamCalVal$CertificateNumber)) {
- |
-
| 98 | -1x | -
- log$error(base::paste0('Cannot find calibration certificate number in ',fileCal[idxFileCal],
- |
-
| 99 | -1x | -
- '. It is not returned in infoCal$file$StreamCalVal$CertificateNumber output from NEONprocIS.cal::def.read.cal.xml'))- |
-
| 100 | -1x | -
- infoCal$file$StreamCalVal$CertificateNumber <- NA- |
-
| 101 | -1x | -
- infoCal$err <- TRUE- |
-
| 102 | -- |
- - |
-
| 103 | -- |
- } else {
- |
-
| 104 | -65x | -
- infoCal$err <- FALSE- |
-
| 105 | -- |
- - |
-
| 106 | -- |
- }- |
-
| 107 | -- |
- - |
-
| 108 | -- |
- # output metadata- |
-
| 109 | -67x | -
- metaCal[[idxFileCal]] <- base::data.frame(path=pathFileCal[idxFileCal],- |
-
| 110 | -67x | -
- file=nameFileCal[idxFileCal],- |
-
| 111 | -67x | -
- timeValiBgn=infoCal$timeVali$StartTime,- |
-
| 112 | -67x | -
- timeValiEnd=infoCal$timeVali$EndTime,- |
-
| 113 | -67x | -
- id=base::as.numeric(infoCal$file$StreamCalVal$CertificateNumber),- |
-
| 114 | -67x | -
- strm=base::as.numeric(infoCal$file$StreamCalVal$StreamID),- |
-
| 115 | -67x | -
- err=infoCal$err,- |
-
| 116 | -67x | -
- stringsAsFactors=FALSE)- |
-
| 117 | -- |
- - |
-
| 118 | -- |
- }- |
-
| 119 | -22x | -
- metaCal <- base::Reduce(f=base::rbind,x=metaCal)- |
-
| 120 | -- |
- - |
-
| 121 | -22x | -
- return(metaCal)- |
-
| 122 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Determine applicable date ranges for calibration- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Given calibration information from several calibration files (as returned- |
-
| 9 | -- |
- #' from NEONprocIS.cal::def.cal.met), and a maximum number of days allowed to use expired- |
-
| 10 | -- |
- #' calibrations after their expiration date, determine the calibrations that apply (and their- |
-
| 11 | -- |
- #' application time ranges) for a date range of interest. Calibration valid date ranges and- |
-
| 12 | -- |
- #' calibration certificate numbers (ID) determine the most relevant calibration to apply, following- |
-
| 13 | -- |
- #' this choice order (1 chosen first):- |
-
| 14 | -- |
- #' 1. higher ID & date of interest within valid date range- |
-
| 15 | -- |
- #' 2. lower ID & date of interest within valid date range- |
-
| 16 | -- |
- #' 3. expired cal with nearest valid end date to beginning date of interest- |
-
| 17 | -- |
- #' 4. lower ID if expiration dates equal for multipe cals in #3- |
-
| 18 | -- |
- #' Note that calibrations with a valid date range beginning after the date range of interest and- |
-
| 19 | -- |
- #' calibrations that are expired more than their max allowable days since expiration are treated- |
-
| 20 | -- |
- #' as if they don't exist. These time periods in the output will be filled with NA values for the- |
-
| 21 | -- |
- #' calibration metadata with the expired flag = TRUE.- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @param metaCal A data frame of calibration metadata as returned from NEONprocIS.cal::def.cal.meta- |
-
| 24 | -- |
- #' @param TimeBgn A POSIXct timestamp of the start date of interest (inclusive)- |
-
| 25 | -- |
- #' @param TimeEnd A POSIXct timestamp of the end date of interest (exclusive)- |
-
| 26 | -- |
- #' @param TimeExpiMax A difftime object of the maxumum time since expiration for which an expired- |
-
| 27 | -- |
- #' calibration may be used (e.g. TimeExpiMax <- as.difftime(10,units='days'). Defaults to NULL,- |
-
| 28 | -- |
- #' which allows an expired calibration to always be used.- |
-
| 29 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 30 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @return A data frame of \cr- |
-
| 33 | -- |
- #' \code{timeBgn} POSIXct. The start date-time (inclusive) for which the calibration applies \cr
- |
-
| 34 | -- |
- #' \code{timeEnd} POSIXct. The end date-time (exclusive) for which the calibration applies \cr
- |
-
| 35 | -- |
- #' \code{file} Character. The name of the calibration file referring to metaCal$file that applies for the date range in columns timeBgn and timeEnd \cr
- |
-
| 36 | -- |
- #' \code{id} Numeric. The calibration id referring to metaCal$id that applies for the date range in columns timeBgn and timeEnd \cr
- |
-
| 37 | -- |
- #' \code{expi} Boolean (TRUE/FALSE). TRUE if the best available calibration is expired for the time period
- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @references- |
-
| 40 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 41 | -- | - - | -
| 42 | -- |
- #' @keywords currently none- |
-
| 43 | -- | - - | -
| 44 | -- |
- #' @examples- |
-
| 45 | -- |
- #' # Not run- |
-
| 46 | -- |
- #' # fileCal <- c('/path/to/file1.xml','/path/to/file2.xml')
- |
-
| 47 | -- |
- #' # metaCal <- NEONprocIS.cal::def.cal.meta(fileCal=fileCal)- |
-
| 48 | -- |
- #' # TimeBgn <- base::as.POSIXct('2019-01-01',tz='GMT')
- |
-
| 49 | -- |
- #' # TimeEnd <- base::as.POSIXct('2019-01-02',tz='GMT')
- |
-
| 50 | -- |
- #' # TimeExpiMax <- base::as.difftime(30,units='days') # allow cals to be used up to 30 days after expiration- |
-
| 51 | -- |
- #' # NEONprocIS.cal::def.cal.slct(metaCal=metaCal,TimeBgn=timeBgn,TimeEnd=timeEnd)- |
-
| 52 | -- | - - | -
| 53 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.meta}
- |
-
| 54 | -- |
- #'- |
-
| 55 | -- |
- #' @export- |
-
| 56 | -- | - - | -
| 57 | -- |
- # changelog and author contributions / copyrights- |
-
| 58 | -- |
- # Cove Sturtevant (2020-02-06)- |
-
| 59 | -- |
- # original creation- |
-
| 60 | -- |
- # Cove Sturtevant (2020-12-08)- |
-
| 61 | -- |
- # added path to calibration directory in output- |
-
| 62 | -- |
- # Cove Sturtevant (2022-08-12)- |
-
| 63 | -- |
- # fixed bug when two cals have the same valid start date- |
-
| 64 | -- |
- ##############################################################################################- |
-
| 65 | -- |
- def.cal.slct <-- |
-
| 66 | -- |
- function(metaCal=NULL,- |
-
| 67 | -- |
- TimeBgn,- |
-
| 68 | -- |
- TimeEnd,- |
-
| 69 | -- |
- TimeExpiMax = NULL,- |
-
| 70 | -- |
- log = NULL) {
- |
-
| 71 | -- |
- # Intialize logging if needed- |
-
| 72 | -27x | -
- if (base::is.null(log)) {
- |
-
| 73 | -27x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 74 | -- |
- }- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Initialize the output data frame- |
-
| 77 | -27x | -
- dmmyTime <-- |
-
| 78 | -27x | -
- base::as.POSIXct(x = numeric(0), origin = as.POSIXct('1970-01-01', tz = 'GMT'))
- |
-
| 79 | -27x | -
- base::attr(dmmyTime, 'tzone') <- 'GMT'- |
-
| 80 | -27x | -
- rpt <-- |
-
| 81 | -27x | -
- base::data.frame(- |
-
| 82 | -27x | -
- timeBgn = dmmyTime,- |
-
| 83 | -27x | -
- timeEnd = dmmyTime,- |
-
| 84 | -27x | -
- path = base::character(0),- |
-
| 85 | -27x | -
- file = base::character(0),- |
-
| 86 | -27x | -
- id = base::character(0),- |
-
| 87 | -27x | -
- expi = base::logical(0),- |
-
| 88 | -27x | -
- stringsAsFactors = FALSE- |
-
| 89 | -- |
- )- |
-
| 90 | -- |
- - |
-
| 91 | -- |
- # Check inputs: TimeBgn and TimeEnd are POSIXct. TimeEnd > TimeBgn. Validate metaCal is a data frame with columns file, timeValiBgn, timeValiEnd, id. Single difftime value or NULL for TimeExpiMax.- |
-
| 92 | -- |
- - |
-
| 93 | -27x | -
- if (!base::is.null(TimeBgn)) {
- |
-
| 94 | -27x | -
- TimeBgn <-- |
-
| 95 | -27x | -
- base::as.POSIXct(TimeBgn, format = '%Y-%m-%dT%H:%M:%SZ', tz = 'GMT')- |
-
| 96 | -- |
- }- |
-
| 97 | -27x | -
- if (!base::is.null(TimeEnd)) {
- |
-
| 98 | -27x | -
- TimeEnd <-- |
-
| 99 | -27x | -
- base::as.POSIXct(TimeEnd, format = '%Y-%m-%dT%H:%M:%SZ', tz = 'GMT')- |
-
| 100 | -- |
- }- |
-
| 101 | -- |
- - |
-
| 102 | -27x | -
- if (TimeEnd < TimeBgn) {
- |
-
| 103 | -1x | -
- stop("In def.cal.slct::::: Check the input, TimeEnd, needs to be later than TimeBgn")
- |
-
| 104 | -- |
- }- |
-
| 105 | -- |
- - |
-
| 106 | -26x | -
- NameList = c('path', 'file', 'timeValiBgn', 'timeValiEnd', 'id')
- |
-
| 107 | -- |
- - |
-
| 108 | -26x | -
- if (!base::is.null(metaCal) && !(all(NameList %in% colnames(metaCal))))- |
-
| 109 | -- |
- {
- |
-
| 110 | -1x | -
- stop("In def.cal.slct::::: Check input metaCal - data frame has columns missing")
- |
-
| 111 | -- |
- }- |
-
| 112 | -- |
- - |
-
| 113 | -- |
- # What if metaCal is an empty data frame, or empty? Need to return the time period as if there were no applicable cal. Do so by creating a data frame with expected columns but zero rows.- |
-
| 114 | -25x | -
- if ((base::is.null(metaCal)) || (nrow(metaCal) == 0)){
- |
-
| 115 | -3x | -
- metaCal <- base::data.frame(path=base::character(0),- |
-
| 116 | -3x | -
- file=base::character(0),- |
-
| 117 | -3x | -
- timeValiBgn=dmmyTime,- |
-
| 118 | -3x | -
- timeValiEnd=dmmyTime,- |
-
| 119 | -3x | -
- id=base::numeric(0),- |
-
| 120 | -3x | -
- stringsAsFactors=FALSE)- |
-
| 121 | -- |
- }- |
-
| 122 | -- |
- - |
-
| 123 | -- |
- # Sort the calibration IDs. Higher calibration ID (more recently generated) is always preferrable unless it is expired.- |
-
| 124 | -25x | -
- metaCal <- metaCal[base::order(metaCal$id, decreasing = TRUE),]- |
-
| 125 | -- |
- - |
-
| 126 | -- |
- # Do initial filtering of calibrations to those that fulfill minimum requirements- |
-
| 127 | -- |
- # 1. Remove cals where valid date range begins after time range of interest- |
-
| 128 | -25x | -
- metaCal <- metaCal[metaCal$timeValiBgn < TimeEnd,]- |
-
| 129 | -- |
- # 2. Remove cals where time range of interest is after the expiration + allowance period- |
-
| 130 | -25x | -
- if (!base::is.null(TimeExpiMax)) {
- |
-
| 131 | -21x | -
- metaCal <- metaCal[metaCal$timeValiEnd + TimeExpiMax > TimeBgn,]- |
-
| 132 | -- |
- }- |
-
| 133 | -- |
- - |
-
| 134 | -- |
- - |
-
| 135 | -- |
- # Run through the calibrations, filling in valid periods.- |
-
| 136 | -- |
- # Start with highest ID, which is the most prefereable for a given date-time- |
-
| 137 | -25x | -
- for (idxRow in base::seq_len(base::nrow(metaCal))) {
- |
-
| 138 | -- |
- # Get an inventory of the remaining time periods without a valid cal- |
-
| 139 | -29x | -
- timeMiss <-- |
-
| 140 | -29x | -
- NEONprocIS.base::def.time.miss(TimeBgn = TimeBgn,- |
-
| 141 | -29x | -
- TimeEnd = TimeEnd,- |
-
| 142 | -29x | -
- timeFull = rpt,- |
-
| 143 | -29x | -
- log=log)- |
-
| 144 | -- |
- - |
-
| 145 | -- |
- # Quit early if we've covered the entire range of interest with valid calibrations- |
-
| 146 | -29x | -
- if (base::nrow(timeMiss) == 0) {
- |
-
| 147 | -6x | -
- break- |
-
| 148 | -- |
- }- |
-
| 149 | -- |
- - |
-
| 150 | -- |
- # Run through each missing time period, trying to fill it with this calibration (if it's valid)- |
-
| 151 | -23x | -
- for (idxTimeMiss in base::seq_len(base::nrow(timeMiss))) {
- |
-
| 152 | -28x | -
- timeBgnIdx <-- |
-
| 153 | -28x | -
- base::max(metaCal$timeValiBgn[idxRow], timeMiss$timeBgn[idxTimeMiss])- |
-
| 154 | -28x | -
- timeEndIdx <-- |
-
| 155 | -28x | -
- base::min(metaCal$timeValiEnd[idxRow], timeMiss$timeEnd[idxTimeMiss])- |
-
| 156 | -- |
- - |
-
| 157 | -- |
- # Place in the output if there is a valid calibration for this period- |
-
| 158 | -28x | -
- if (timeBgnIdx <= timeEndIdx && timeBgnIdx < timeMiss$timeEnd) {
- |
-
| 159 | -17x | -
- rpt <-- |
-
| 160 | -17x | -
- base::rbind(- |
-
| 161 | -17x | -
- rpt,- |
-
| 162 | -17x | -
- base::data.frame(- |
-
| 163 | -17x | -
- timeBgn = timeBgnIdx,- |
-
| 164 | -17x | -
- timeEnd = timeEndIdx,- |
-
| 165 | -17x | -
- path = metaCal$path[idxRow],- |
-
| 166 | -17x | -
- file = metaCal$file[idxRow],- |
-
| 167 | -17x | -
- id = metaCal$id[idxRow],- |
-
| 168 | -17x | -
- expi = FALSE,- |
-
| 169 | -17x | -
- stringsAsFactors = FALSE- |
-
| 170 | -- |
- )- |
-
| 171 | -- |
- )- |
-
| 172 | -- |
- }- |
-
| 173 | -- |
- }- |
-
| 174 | -- |
- - |
-
| 175 | -- |
- } # End filling valid cal periods- |
-
| 176 | -- |
- - |
-
| 177 | -- |
- # Sort (for ease in debugging)- |
-
| 178 | -25x | -
- rpt <- rpt[base::order(rpt$timeBgn), ]- |
-
| 179 | -- |
- - |
-
| 180 | -- |
- # Get an inventory of the remaining time periods without a valid cal- |
-
| 181 | -25x | -
- timeMiss <-- |
-
| 182 | -25x | -
- NEONprocIS.base::def.time.miss(TimeBgn = TimeBgn,- |
-
| 183 | -25x | -
- TimeEnd = TimeEnd,- |
-
| 184 | -25x | -
- timeFull = rpt,- |
-
| 185 | -25x | -
- log=log)- |
-
| 186 | -- |
- - |
-
| 187 | -- |
- # Now run through the remaining periods without a valid calibration.- |
-
| 188 | -- |
- # Fill with most recently expired (if available)- |
-
| 189 | -25x | -
- for (idxTimeMiss in base::seq_len(base::nrow(timeMiss))) {
- |
-
| 190 | -22x | -
- fillNa <- FALSE # Initialize for later- |
-
| 191 | -- |
- - |
-
| 192 | -- |
- # Get the time difference between the beginning of this period and the end date of available calibrations- |
-
| 193 | -22x | -
- timeDiffExpi <-- |
-
| 194 | -22x | -
- timeMiss$timeBgn[idxTimeMiss] - metaCal$timeValiEnd- |
-
| 195 | -22x | -
- base::names(timeDiffExpi) <- metaCal$id- |
-
| 196 | -- |
- # Must be expired (since we filled valid cal periods already) & within allowance period- |
-
| 197 | -22x | -
- if (base::is.null(TimeExpiMax)) {
- |
-
| 198 | -- |
- # no limit on time past expiration- |
-
| 199 | -4x | -
- timeDiffExpi <- timeDiffExpi[timeDiffExpi >= 0]- |
-
| 200 | -- |
- } else {
- |
-
| 201 | -- |
- # Within expiration allowance period- |
-
| 202 | -18x | -
- timeDiffExpi <-- |
-
| 203 | -18x | -
- timeDiffExpi[timeDiffExpi >= 0 & timeDiffExpi < TimeExpiMax]- |
-
| 204 | -- |
- }- |
-
| 205 | -- |
- - |
-
| 206 | -- |
- # Do we have any acceptable expired cals to use?- |
-
| 207 | -22x | -
- if (base::length(timeDiffExpi) > 0) {
- |
-
| 208 | -- |
- # Choose the one that expired closest to our time range start date- |
-
| 209 | -5x | -
- timeDiffExpi <-- |
-
| 210 | -5x | -
- timeDiffExpi[timeDiffExpi == base::min(timeDiffExpi)]- |
-
| 211 | -5x | -
- idCalExpi <- base::names(timeDiffExpi)- |
-
| 212 | -- |
- - |
-
| 213 | -- |
- # If there is more than one closest expired cal (expired on same date),- |
-
| 214 | -- |
- # take the highest cal ID- |
-
| 215 | -5x | -
- if (base::length(timeDiffExpi) > 1) {
- |
-
| 216 | -2x | -
- idCalExpiMax <- base::max(idCalExpi)- |
-
| 217 | -2x | -
- timeDiffExpi <- timeDiffExpi[idCalExpi == idCalExpiMax]- |
-
| 218 | -2x | -
- idCalExpi <- idCalExpiMax- |
-
| 219 | -- |
- }- |
-
| 220 | -- |
- - |
-
| 221 | -- |
- # Get the file associated with this id- |
-
| 222 | -5x | -
- idxRowCalExpi <- base::which(metaCal$id == idCalExpi)[1]- |
-
| 223 | -5x | -
- fileCalExpi <- metaCal$file[idxRowCalExpi]- |
-
| 224 | -- |
- - |
-
| 225 | -- |
- # Use the cal only up to the allowable expired period- |
-
| 226 | -5x | -
- if (base::is.null(TimeExpiMax)) {
- |
-
| 227 | -- |
- # We can fill the whole period. No limit on time past expiration- |
-
| 228 | -2x | -
- timeEndExpi <- timeMiss$timeEnd[idxTimeMiss]- |
-
| 229 | -- |
- } else {
- |
-
| 230 | -- |
- # Fill only to the expiration allowance period- |
-
| 231 | -3x | -
- timeEndExpi <-- |
-
| 232 | -3x | -
- base::min(metaCal$timeValiEnd[idxRowCalExpi] + TimeExpiMax,timeMiss$timeEnd[idxTimeMiss])- |
-
| 233 | -- |
- - |
-
| 234 | -- |
- # Fill in NA values for the time past expiration allowance- |
-
| 235 | -3x | -
- if(timeEndExpi < timeMiss$timeEnd[idxTimeMiss]){
- |
-
| 236 | -1x | -
- rpt <-- |
-
| 237 | -1x | -
- base::rbind(- |
-
| 238 | -1x | -
- rpt,- |
-
| 239 | -1x | -
- base::data.frame(- |
-
| 240 | -1x | -
- timeBgn = timeEndExpi,- |
-
| 241 | -1x | -
- timeEnd = timeMiss$timeEnd[idxTimeMiss],- |
-
| 242 | -1x | -
- path = NA,- |
-
| 243 | -1x | -
- file = NA,- |
-
| 244 | -1x | -
- id = NA,- |
-
| 245 | -1x | -
- expi = TRUE,- |
-
| 246 | -1x | -
- stringsAsFactors = FALSE- |
-
| 247 | -- |
- )- |
-
| 248 | -- |
- )- |
-
| 249 | -- |
- }- |
-
| 250 | -- |
- }- |
-
| 251 | -- |
- - |
-
| 252 | -- |
- # Place expired cal in the output- |
-
| 253 | -5x | -
- rpt <-- |
-
| 254 | -5x | -
- base::rbind(- |
-
| 255 | -5x | -
- rpt,- |
-
| 256 | -5x | -
- base::data.frame(- |
-
| 257 | -5x | -
- timeBgn = timeMiss$timeBgn[idxTimeMiss],- |
-
| 258 | -5x | -
- timeEnd = timeEndExpi,- |
-
| 259 | -5x | -
- path = metaCal$path[idxRowCalExpi],- |
-
| 260 | -5x | -
- file = metaCal$file[idxRowCalExpi],- |
-
| 261 | -5x | -
- id = idCalExpi,- |
-
| 262 | -5x | -
- expi = TRUE,- |
-
| 263 | -5x | -
- stringsAsFactors = FALSE- |
-
| 264 | -- |
- )- |
-
| 265 | -- |
- )- |
-
| 266 | -- |
- - |
-
| 267 | -- |
- } else {
- |
-
| 268 | -- |
- # Cannot fill this missing time period. No expired cal within allowance period- |
-
| 269 | -- |
- # Fill file, id, and expi fields with NA- |
-
| 270 | -17x | -
- rpt <-- |
-
| 271 | -17x | -
- base::rbind(- |
-
| 272 | -17x | -
- rpt,- |
-
| 273 | -17x | -
- base::data.frame(- |
-
| 274 | -17x | -
- timeBgn = timeMiss$timeBgn[idxTimeMiss],- |
-
| 275 | -17x | -
- timeEnd = timeMiss$timeEnd[idxTimeMiss],- |
-
| 276 | -17x | -
- path = NA,- |
-
| 277 | -17x | -
- file = NA,- |
-
| 278 | -17x | -
- id = NA,- |
-
| 279 | -17x | -
- expi = TRUE,- |
-
| 280 | -17x | -
- stringsAsFactors = FALSE- |
-
| 281 | -- |
- )- |
-
| 282 | -- |
- )- |
-
| 283 | -- |
- - |
-
| 284 | -17x | -
- next- |
-
| 285 | -- |
- }- |
-
| 286 | -- |
- - |
-
| 287 | -- |
- } # End loop through periods without a valid cal- |
-
| 288 | -- |
- - |
-
| 289 | -- |
- # Sort for output- |
-
| 290 | -25x | -
- rpt <- rpt[base::order(rpt$timeBgn), ]- |
-
| 291 | -- |
- - |
-
| 292 | -25x | -
- return(rpt)- |
-
| 293 | -- |
- } # End function- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Convert CVALA0 to CVALA1 and to a 1 degree polynomial- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- |
- #' Teresa Burlingame \email{tburlingame@battelleecology.org}
- |
-
| 7 | -- | - - | -
| 8 | -- |
- #' @description- |
-
| 9 | -- |
- #' Definition function. Apply polynomial to data. If CVAL uses A0 when it should be A1, it needs conversion to- |
-
| 10 | -- |
- #' level 1 polynomial before calculating. A0 is traditionally an offset, but in the calibration it- |
-
| 11 | -- |
- #' is treated as the multiplier. (eg #bucket tips* A0 = mm precip)- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 14 | -- |
- #' @param infoCal A list of calibration information as returned from NEONprocIS.cal::def.read.cal.xml.- |
-
| 15 | -- |
- #' One list element must be \code{cal}, which is a data frame of polynomial calibration coefficients.
- |
-
| 16 | -- |
- #' This data frame must include columns:\cr- |
-
| 17 | -- |
- #' \code{Name} String. The name of the coefficient. Must fit regular expression CVALA[0-9]\cr
- |
-
| 18 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 19 | -- |
- #' Defaults to NULL, in which case converted data will be retured as NA.- |
-
| 20 | -- |
- #' @param varConv A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 21 | -- |
- #' which calibrated output will be computed (all other columns will be ignored). Note that for other- |
-
| 22 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame. Defaults to the first- |
-
| 23 | -- |
- #' column in \code{data}.
- |
-
| 24 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 25 | -- |
- #' NEONprocIS.cal::wrap.cal.conv for what this input is.- |
-
| 26 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 27 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 28 | -- |
- #' created and used within the function.- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @return A Numeric vector of calibrated data\cr- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @references- |
-
| 33 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 34 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @keywords Currently none- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @examples- |
-
| 39 | -- |
- #' data=data.frame(data=c(1,2,3))- |
-
| 40 | -- |
- #' infoCal <- data.frame(Name=c('CVALA0'),Value=c(.4985),stringsAsFactors=FALSE)
- |
-
| 41 | -- |
- #' def.cal.conv.poly.tip(data=data,infoCal=infoCal)- |
-
| 42 | -- | - - | -
| 43 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.b}
- |
-
| 45 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.m}
- |
-
| 46 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.cal.conv}
- |
-
| 47 | -- | - - | -
| 48 | -- |
- #' @export- |
-
| 49 | -- | - - | -
| 50 | -- |
- # changelog and author contributions / copyrights- |
-
| 51 | -- |
- # Teresa Burlingame (2025-06-12)- |
-
| 52 | -- |
- # Original creation- |
-
| 53 | -- | - - | -
| 54 | -- |
- ##############################################################################################- |
-
| 55 | -- |
- def.cal.conv.poly.a0.as.a1 <- function(data = data.frame(data=base::numeric(0)),- |
-
| 56 | -- |
- infoCal = NULL,- |
-
| 57 | -- |
- varConv = base::names(data)[1],- |
-
| 58 | -- |
- calSlct=NULL,- |
-
| 59 | -- |
- log = NULL) {
- |
-
| 60 | -- |
- # Intialize logging if needed- |
-
| 61 | -4x | -
- if (base::is.null(log)) {
- |
-
| 62 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 63 | -- |
- }- |
-
| 64 | -- | - - | -
| 65 | -- |
- # Ensure input is data frame- |
-
| 66 | -4x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varConv,TestEmpty=FALSE, log = log)- |
-
| 67 | -4x | -
- if (!chk) {
- |
-
| 68 | -1x | -
- stop()- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # Check to see if data to be calibrated is a numeric array- |
-
| 72 | -3x | -
- chk <-- |
-
| 73 | -3x | -
- NEONprocIS.base::def.validate.vector(data[[varConv]], TestEmpty = FALSE, TestNumc = TRUE, log = log)- |
-
| 74 | -3x | -
- if (!chk) {
- |
-
| 75 | -! | -
- stop()- |
-
| 76 | -- |
- }- |
-
| 77 | -- |
- - |
-
| 78 | -- |
- # If infoCal is NULL, return NA data- |
-
| 79 | -3x | -
- if (is.null(infoCal)) {
- |
-
| 80 | -1x | -
- log$warn('No calibration information supplied, returning NA values for converted data.')
- |
-
| 81 | -1x | -
- dataConv <- NA * data[[varConv]]- |
-
| 82 | -1x | -
- return(dataConv)- |
-
| 83 | -- |
- } else {
- |
-
| 84 | -- |
- # Check to see if infoCal is a list- |
-
| 85 | -2x | -
- chkList <-- |
-
| 86 | -2x | -
- NEONprocIS.base::def.validate.list(infoCal, log = log)- |
-
| 87 | -2x | -
- if (!chkList) {
- |
-
| 88 | -! | -
- chk <- c(chk, chkList)- |
-
| 89 | -- |
- }- |
-
| 90 | -- |
- - |
-
| 91 | -- |
- }- |
-
| 92 | -- |
- - |
-
| 93 | -- |
- # Validate calibration information- |
-
| 94 | -2x | -
- if (!NEONprocIS.cal::def.validate.info.cal(infoCal,NameList='cal',log=log)) {
- |
-
| 95 | -! | -
- stop()- |
-
| 96 | -- |
- }- |
-
| 97 | -- |
- - |
-
| 98 | -- |
- #add 0 level to coefficient list to place A0 at A1 position- |
-
| 99 | -2x | -
- coefPoly <- c(0, infoCal$cal$Value[infoCal$cal$Name == 'CVALA0'])- |
-
| 100 | -- |
- - |
-
| 101 | -- |
- # Construct the polynomial calibration function- |
-
| 102 | -2x | -
- func <- polynom::polynomial(coef = coefPoly)- |
-
| 103 | -- |
- - |
-
| 104 | -- |
- # Convert data using the calibration function- |
-
| 105 | -2x | -
- dataConv <- stats::predict(object = func, newdata = data[[varConv]]) # Bucket tip converted to precip.- |
-
| 106 | -- | - - | -
| 107 | -2x | -
- return(dataConv)- |
-
| 108 | -- |
- - |
-
| 109 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Convert raw to calibrated data using NEON CVALM polynomial calibration coefficients- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Apply NEON calibration polynomial function contained in coefficients- |
-
| 9 | -- |
- #' CVALM0, CVALM1, CVALM2, etc. to convert raw data to calibrated data.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 12 | -- |
- #' @param infoCal A list of calibration information as returned from NEONprocIS.cal::def.read.cal.xml.- |
-
| 13 | -- |
- #' One list element must be \code{cal}, which is a data frame of polynomial calibration coefficients.
- |
-
| 14 | -- |
- #' This data frame must include columns:\cr- |
-
| 15 | -- |
- #' \code{Name} String. The name of the coefficient. Must fit regular expression CVALM[0-9]\cr
- |
-
| 16 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 17 | -- |
- #' Defaults to NULL, in which case converted data will be retured as NA.- |
-
| 18 | -- |
- #' @param varConv A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 19 | -- |
- #' which the calibration will be applied (all other columns will be ignored). Note that for other- |
-
| 20 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame. Defaults to the first- |
-
| 21 | -- |
- #' column in \code{data}.
- |
-
| 22 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 23 | -- |
- #' NEONprocIS.cal::wrap.cal.conv for what this input is.- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 26 | -- |
- #' created and used within the function.- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @return A Numeric vector of calibrated data\cr- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @references- |
-
| 31 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 32 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @keywords Currently none- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @examples- |
-
| 37 | -- |
- #' data=data.frame(data=c(1,2,3))- |
-
| 38 | -- |
- #' infoCal <- data.frame(Name=c('CVALB1','CVALB0'),Value=c(10,1),stringsAsFactors=FALSE)
- |
-
| 39 | -- |
- #' def.cal.conv.poly.b(data=data,infoCal=infoCal)- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 42 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly}
- |
-
| 43 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.b}
- |
-
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.cal.conv}
- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @export- |
-
| 47 | -- | - - | -
| 48 | -- |
- # changelog and author contributions / copyrights- |
-
| 49 | -- |
- # Cove Sturtevant (2020-07-28)- |
-
| 50 | -- |
- # original creation, from def.cal.conv.poly- |
-
| 51 | -- |
- # Cove Sturtevant (2020-08-31)- |
-
| 52 | -- |
- # adjusted inputs to conform to new generic format for all cal funcs- |
-
| 53 | -- |
- # This includes inputting the entire data frame, the- |
-
| 54 | -- |
- # variable to be calibrated, and the (unused) argument calSlct- |
-
| 55 | -- |
- ##############################################################################################- |
-
| 56 | -- |
- def.cal.conv.poly.m <- function(data = data.frame(data=base::numeric(0)),- |
-
| 57 | -- |
- infoCal = NULL,- |
-
| 58 | -- |
- varConv = base::names(data)[1],- |
-
| 59 | -- |
- calSlct=NULL,- |
-
| 60 | -- |
- log = NULL) {
- |
-
| 61 | -- |
- # Intialize logging if needed- |
-
| 62 | -3x | -
- if (base::is.null(log)) {
- |
-
| 63 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 64 | -- |
- }- |
-
| 65 | -- | - - | -
| 66 | -- |
- # Ensure input is data frame- |
-
| 67 | -3x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varConv,TestEmpty=FALSE, log = log)- |
-
| 68 | -3x | -
- if (!chk) {
- |
-
| 69 | -1x | -
- stop()- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Check to see if data to be calibrated is a numeric array- |
-
| 73 | -2x | -
- chk <-- |
-
| 74 | -2x | -
- NEONprocIS.base::def.validate.vector(data[[varConv]], TestEmpty = FALSE, TestNumc = TRUE, log = log)- |
-
| 75 | -2x | -
- if (!chk) {
- |
-
| 76 | -! | -
- stop()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # If infoCal is NULL, return NA data- |
-
| 80 | -2x | -
- if (is.null(infoCal)) {
- |
-
| 81 | -1x | -
- log$warn('No calibration information supplied, returning NA values for converted data.')
- |
-
| 82 | -1x | -
- dataConv <- NA * data[[varConv]]- |
-
| 83 | -1x | -
- return(dataConv)- |
-
| 84 | -- |
- } else {
- |
-
| 85 | -- |
- # Check to see if infoCal is a list- |
-
| 86 | -1x | -
- chkList <-- |
-
| 87 | -1x | -
- NEONprocIS.base::def.validate.list(infoCal, log = log)- |
-
| 88 | -1x | -
- if (!chkList) {
- |
-
| 89 | -! | -
- chk <- c(chk, chkList)- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- }- |
-
| 93 | -- | - - | -
| 94 | -- |
- # Construct the polynomial calibration function- |
-
| 95 | -1x | -
- func <-- |
-
| 96 | -1x | -
- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal, Prfx='CVALM', log = log)- |
-
| 97 | -- |
- - |
-
| 98 | -- |
- # Convert data using the calibration function- |
-
| 99 | -1x | -
- dataConv <- stats::predict(object = func, newdata = data[[varConv]])- |
-
| 100 | -- |
- - |
-
| 101 | -1x | -
- return(dataConv)- |
-
| 102 | -- |
- - |
-
| 103 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read NEON FDAS uncertainty coefficients- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in NEON FDAS uncertainty coefficients- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param NameFile String. Name (including relative or absolute path) of json file.- |
-
| 11 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 12 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 13 | -- | - - | -
| 14 | -- |
- - |
-
| 15 | -- |
- #' @return A data frame of FDAS uncertainty coefficients:\cr- |
-
| 16 | -- |
- #' \code{Name} Character. Name of the coefficient.\cr
- |
-
| 17 | -- |
- #' \code{Value} Character. Value of the coefficient.\cr
- |
-
| 18 | -- |
- #' \code{.attrs} Character. Relevant attribute (i.e. units)\cr
- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @references Currently none- |
-
| 21 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @keywords Currently none- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @examples Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @seealso Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @export- |
-
| 30 | -- | - - | -
| 31 | -- |
- # changelog and author contributions / copyrights- |
-
| 32 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 33 | -- |
- # original creation- |
-
| 34 | -- |
- ##############################################################################################- |
-
| 35 | -- |
- def.read.ucrt.coef.fdas <- function(NameFile,log=NULL){
- |
-
| 36 | -- |
- # initialize logging if necessary- |
-
| 37 | -4x | -
- if (base::is.null(log)) {
- |
-
| 38 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 39 | -- |
- }- |
-
| 40 | -- |
- - |
-
| 41 | -- |
- # Open FDAS uncertainty file- |
-
| 42 | -4x | -
- ucrtCoefFdas <- base::try(rjson::fromJSON(file=NameFile,simplify=TRUE),silent=FALSE)- |
-
| 43 | -4x | -
- if(base::class(ucrtCoefFdas) == 'try-error'){
- |
-
| 44 | -- |
- # Generate error and stop execution- |
-
| 45 | -1x | -
- log$error(base::paste0('File: ', NameFile, ' is unreadable.'))
- |
-
| 46 | -1x | -
- stop()- |
-
| 47 | -- |
- }- |
-
| 48 | -- |
- - |
-
| 49 | -- |
- # Convert to data frame- |
-
| 50 | -3x | -
- ucrtCoefFdas <- base::lapply(ucrtCoefFdas,base::as.data.frame,stringsAsFactors=FALSE)- |
-
| 51 | -3x | -
- ucrtCoefFdas <- base::do.call(base::rbind,ucrtCoefFdas)- |
-
| 52 | -- |
- - |
-
| 53 | -- |
- - |
-
| 54 | -3x | -
- return(ucrtCoefFdas)- |
-
| 55 | -- |
- - |
-
| 56 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Quality flag for suspect calibration- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Check the CVALR1 coefficient in the calibration file. If it is present,- |
-
| 9 | -- |
- #' set the suspect calibration flag for all data values to the value of the coefficient- |
-
| 10 | -- |
- #' (1=bad,0=good). If the CVALR1 coefficient is not present, set the suspect calibration flag- |
-
| 11 | -- |
- #' to 0. If no calibration information is available, set the flag to -1.- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @param data Numeric vector of raw measurements- |
-
| 14 | -- |
- #' @param infoCal A list of calibration information as returned from NEONprocIS.cal::def.read.cal.xml.- |
-
| 15 | -- |
- #' One list element must be \code{cal}, which is a data frame of polynomial calibration coefficients.
- |
-
| 16 | -- |
- #' This data frame must include columns:\cr- |
-
| 17 | -- |
- #' \code{Name} String. The name of the coefficient.\cr
- |
-
| 18 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 19 | -- |
- #' Defaults to NULL, in which case flag value will be -1.- |
-
| 20 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 21 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 22 | -- |
- #' created and used within the function.- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @return A numeric vector the same length as input argument "data" of suspect calibration flag- |
-
| 25 | -- |
- #' values (1=bad,0=good,-1=could not evaluate).- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @references- |
-
| 28 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @keywords Currently none- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @examples- |
-
| 33 | -- |
- #' data <- c(1,2,3,4,5)- |
-
| 34 | -- |
- #' infoCal <- list(cal=data.frame(Name=c('CVALR1','CVALA0'),Value=c(1,0),stringsAsFactors=FALSE))
- |
-
| 35 | -- |
- #' qfSusp <- NEONprocIS.cal::def.qf.cal.susp(data,infoCal)- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @export- |
-
| 40 | -- | - - | -
| 41 | -- |
- # changelog and author contributions / copyrights- |
-
| 42 | -- |
- # Cove Sturtevant (2020-02-12)- |
-
| 43 | -- |
- # original creation- |
-
| 44 | -- |
- ##############################################################################################- |
-
| 45 | -- |
- def.qf.cal.susp <- function(data=base::numeric(0),- |
-
| 46 | -- |
- infoCal = NULL,- |
-
| 47 | -- |
- log = NULL) {
- |
-
| 48 | -- |
- # Intialize logging if needed- |
-
| 49 | -6x | -
- if (base::is.null(log)) {
- |
-
| 50 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 51 | -- |
- }- |
-
| 52 | -- | - - | -
| 53 | -- |
- # Check to see if data is a numeric array- |
-
| 54 | -6x | -
- chk <- NEONprocIS.base::def.validate.vector(data,TestEmpty = FALSE,log=log)- |
-
| 55 | -6x | -
- if (!chk){
- |
-
| 56 | -1x | -
- stop()- |
-
| 57 | -- |
- }- |
-
| 58 | -- |
- - |
-
| 59 | -- |
- # Initialize the flag- |
-
| 60 | -5x | -
- qfSusp <- data #- |
-
| 61 | -5x | -
- qfSusp[] <- -1 # Initialize to "cannot evaluate"- |
-
| 62 | -- |
- - |
-
| 63 | -- |
- # If infoCal is NULL, return flag. No cal to evaluate.- |
-
| 64 | -5x | -
- if(base::is.null(infoCal)){
- |
-
| 65 | -1x | -
- log$debug('No calibration information supplied, returning -1 for suspect calibration flag.')
- |
-
| 66 | -1x | -
- return(base::as.integer(qfSusp))- |
-
| 67 | -- |
- }- |
-
| 68 | -- | - - | -
| 69 | -- |
- # Validate calibration information- |
-
| 70 | -4x | -
- if (!NEONprocIS.cal::def.validate.info.cal (infoCal,NameList='cal',log=log)) {
- |
-
| 71 | -! | -
- stop()- |
-
| 72 | -- |
- }- |
-
| 73 | -- |
- - |
-
| 74 | -- |
- # Check for calibration coefficient CVALR1.- |
-
| 75 | -4x | -
- if('CVALR1' %in% infoCal$cal$Name){
- |
-
| 76 | -- |
- # If it is present, set the flag to it's value.- |
-
| 77 | -1x | -
- qfSusp[] <- base::as.numeric(infoCal$cal$Value[infoCal$cal$Name == 'CVALR1'][1])- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- } else {
- |
-
| 80 | -- |
- # If it is not present, set the flag to 0.- |
-
| 81 | -3x | -
- qfSusp[] <- 0- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -4x | -
- return(base::as.integer(qfSusp))- |
-
| 86 | -- | - - | -
| 87 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Combine measurement uncertainties by adding them in quadrature.- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Reads in a data frame of uncertainties and adds each row in quadrature.- |
-
| 9 | -- |
- #' NA values are NOT ignored.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param ucrt Numeric data frame of uncertainties to be combined.- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 14 | -- |
- #' created and used within the function.- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @return A data frame with a single numeric column:\cr- |
-
| 17 | -- |
- #' \code{ucrtComb} - combined measurement uncertainty resulting by adding in quadrature all the
- |
-
| 18 | -- |
- #' uncertainties provided in the input data frame \code{ucrt}.
- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @references- |
-
| 21 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 22 | -- |
- #' NEON.DOC.000785 TIS Level 1 Data products Uncertainty Budget Estimation Plan- |
-
| 23 | -- |
- #' NEON.DOC.000746 Calibration Fixture and Sensor Uncertainty Analysis: CVAL 2014 Uncertainty Manual- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @keywords combined uncertainty- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @examples- |
-
| 28 | -- |
- #' ucrt <- data.frame(ucrtA=c(1,2,1,1,2),ucrtB=c(5,6,7,8,9),stringsAsFactors=FALSE)- |
-
| 29 | -- |
- #' NEONprocIS.cal::def.ucrt.comb(data=data,ucrtCoef=ucrtCoef)- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 32 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.rstc.poly}
- |
-
| 33 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.volt.poly}
- |
-
| 34 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.meas.cnst}
- |
-
| 35 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.meas.mult}
- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @seealso \link[NEONprocIS.base]{def.log.init}
- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @export- |
-
| 40 | -- | - - | -
| 41 | -- |
- # changelog and author contributions / copyrights- |
-
| 42 | -- |
- # Cove Sturtevant (2020-02-03)- |
-
| 43 | -- |
- # original creation- |
-
| 44 | -- |
- ##############################################################################################- |
-
| 45 | -- |
- def.ucrt.comb <- function(ucrt, log = NULL) {
- |
-
| 46 | -- |
- # Initialize logging if necessary- |
-
| 47 | -6x | -
- if (base::is.null(log)) {
- |
-
| 48 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 49 | -- |
- }- |
-
| 50 | -- |
- - |
-
| 51 | -- |
- # Error check- |
-
| 52 | -6x | -
- if (!NEONprocIS.base::def.validate.dataframe(ucrt,- |
-
| 53 | -6x | -
- TestNa = FALSE,- |
-
| 54 | -6x | -
- TestNumc = TRUE,- |
-
| 55 | -6x | -
- log = log)) {
- |
-
| 56 | -1x | -
- stop()- |
-
| 57 | -- |
- }- |
-
| 58 | -- |
- - |
-
| 59 | -- |
- # Combine uncertainties- |
-
| 60 | -5x | -
- ucrtComb <- base::sqrt(base::rowSums(x = ucrt^2, na.rm = FALSE))- |
-
| 61 | -- |
- - |
-
| 62 | -- |
- # Create data frame- |
-
| 63 | -5x | -
- rpt <- base::data.frame(ucrtComb = ucrtComb, stringsAsFactors = FALSE)- |
-
| 64 | -- |
- - |
-
| 65 | -5x | -
- return(rpt)- |
-
| 66 | -- |
- - |
-
| 67 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compute uncertainty attributed to NEON FDAS resistance measurements (and CVALA polynomial calibration conversion)- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Computes L0' uncertainty imposed by a NEON field data acquisition system (FDAS)- |
-
| 9 | -- |
- #' when making resistance measurements and using a polynomial calibration conversion function with CVALA- |
-
| 10 | -- |
- #' coefficients.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param data Data frame of raw measurements. Note that the column/variable indicated in varUcrt must be numeric.- |
-
| 13 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 14 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml). Included in this list must be infoCal$cal and info$ucrt,- |
-
| 15 | -- |
- #' which are data frames of calibration coefficients and uncertainty coeffcients, respectively.- |
-
| 16 | -- |
- #' Columns of these data frames are:\cr- |
-
| 17 | -- |
- #' \code{Name} String. The name of the coefficient. \cr
- |
-
| 18 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 19 | -- |
- #' @param varUcrt A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 20 | -- |
- #' which FDAS uncertainty data will be computed (all other columns will be ignored). Note that for other- |
-
| 21 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame, so long as the function- |
-
| 22 | -- |
- #' knows that. Defaults to the first column in \code{data}.
- |
-
| 23 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 24 | -- |
- #' NEONprocIS.cal::wrap.ucrt.dp0p for what this input is.- |
-
| 25 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 26 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 27 | -- |
- #' created and used within the function.- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @return A data frame with the following variables:\cr- |
-
| 30 | -- |
- #' \code{ucrt$raw} - raw reading value (i.e. same as input data)\cr
- |
-
| 31 | -- |
- #' \code{ucrt$dervCal} - 1st derivative of calibration function evaluated at raw reading value (e.g.
- |
-
| 32 | -- |
- #' partial derivative of a temperature measurement with respect to the resistance reading)\cr- |
-
| 33 | -- |
- #' \code{ucrt$ucrtFdas} - standard uncertainty of individual measurement introduced by the Field DAS \cr
- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @references- |
-
| 36 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 37 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @keywords Currently none- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @examples Currently none- |
-
| 42 | -- | - - | -
| 43 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.func.poly}
- |
-
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @export- |
-
| 47 | -- | - - | -
| 48 | -- |
- # changelog and author contributions / copyrights- |
-
| 49 | -- |
- # Cove Sturtevant (2020-01-31)- |
-
| 50 | -- |
- # original creation- |
-
| 51 | -- |
- # Cove Sturtevant (2020-05-12)- |
-
| 52 | -- |
- # Bug fix - allow code to produce NAs if infoCal$cal is NULL but infoCal$ucrt is not NULL- |
-
| 53 | -- |
- # Cove Sturtevant (2020-09-02)- |
-
| 54 | -- |
- # adjusted inputs to conform to new generic format- |
-
| 55 | -- |
- # This includes inputting the entire data frame, the- |
-
| 56 | -- |
- # variable to be generate uncertainty info for, and the (unused) argument calSlct- |
-
| 57 | -- |
- ##############################################################################################- |
-
| 58 | -- |
- def.ucrt.fdas.rstc.poly <- function(data = data.frame(data=base::numeric(0)),- |
-
| 59 | -- |
- varUcrt = base::names(data)[1],- |
-
| 60 | -- |
- calSlct=NULL,- |
-
| 61 | -- |
- infoCal = NULL,- |
-
| 62 | -- |
- log = NULL) {
- |
-
| 63 | -- |
- # initialize logging if necessary- |
-
| 64 | -4x | -
- if (base::is.null(log)) {
- |
-
| 65 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 66 | -- |
- }- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Ensure input is data frame with the target variable in it- |
-
| 69 | -4x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varUcrt,TestEmpty=FALSE, log = log)- |
-
| 70 | -4x | -
- if (!chk) {
- |
-
| 71 | -! | -
- stop()- |
-
| 72 | -- |
- }- |
-
| 73 | -- |
- - |
-
| 74 | -- |
- # Check data input is numeric- |
-
| 75 | -4x | -
- if (!NEONprocIS.base::def.validate.vector(data[[varUcrt]],TestEmpty = FALSE, TestNumc = TRUE, log=log)) {
- |
-
| 76 | -! | -
- stop()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # Initialize uncertainty output- |
-
| 80 | -4x | -
- dataUcrt <- data[[varUcrt]] # Target variable to compute uncertainty for- |
-
| 81 | -4x | -
- ucrt <-- |
-
| 82 | -4x | -
- base::data.frame(raw = dataUcrt,- |
-
| 83 | -4x | -
- dervCal = NA * dataUcrt,- |
-
| 84 | -4x | -
- ucrtFdas = NA * dataUcrt)- |
-
| 85 | -- |
- - |
-
| 86 | -- |
- # If infoCal is NULL, return NA data- |
-
| 87 | -4x | -
- if (base::is.null(infoCal$cal)) {
- |
-
| 88 | -1x | -
- log$debug('No calibration information supplied, returning NA values for FDAS uncertainty.')
- |
-
| 89 | -1x | -
- return(ucrt)- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- # Check format of infoCal- |
-
| 93 | -3x | -
- if (!NEONprocIS.cal::def.validate.info.cal(infoCal,- |
-
| 94 | -3x | -
- CoefUcrt = c('U_CVALR1', 'U_CVALR4'),
- |
-
| 95 | -3x | -
- log = log)) {
- |
-
| 96 | -1x | -
- stop()- |
-
| 97 | -- |
- }- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- # Compute derivative of calibration function- |
-
| 100 | -2x | -
- func <- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal)- |
-
| 101 | -2x | -
- funcDerv <- stats::deriv(func)- |
-
| 102 | -2x | -
- ucrt$dervCal <-- |
-
| 103 | -2x | -
- stats::predict(object = funcDerv, newdata = dataUcrt) # Eval derivative at each measurement- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- # Retrieve the uncertainty coefficients for resistance measurements- |
-
| 106 | -- |
- # Combined, relative FDAS uncertainty of an individual measurement (U_CVALR1, unitless).- |
-
| 107 | -2x | -
- coefUcrtFdas <-- |
-
| 108 | -2x | -
- base::as.numeric(infoCal$ucrt$Value[infoCal$ucrt$Name == "U_CVALR1"])- |
-
| 109 | -- |
- - |
-
| 110 | -- |
- # Check that we have only 1 coefficient to apply- |
-
| 111 | -2x | -
- if(base::length(coefUcrtFdas) > 1){
- |
-
| 112 | -2x | -
- log$warn('Multiple "U_CVALR1" coefficients found in the uncertainty coefficients. Using the first encountered.')
- |
-
| 113 | -2x | -
- coefUcrtFdas <- coefUcrtFdas[1]- |
-
| 114 | -- |
- }- |
-
| 115 | -- |
- - |
-
| 116 | -- |
- # Offset imposed by the FDAS, in units of resistance (U_CVALR4)- |
-
| 117 | -2x | -
- coefUcrtFdasOfst <-- |
-
| 118 | -2x | -
- base::as.numeric(infoCal$ucrt$Value[infoCal$ucrt$Name == "U_CVALR4"])- |
-
| 119 | -- |
- - |
-
| 120 | -- |
- # Check that we have only 1 coefficient to apply- |
-
| 121 | -2x | -
- if(base::length(coefUcrtFdasOfst) > 1){
- |
-
| 122 | -1x | -
- log$warn('Multiple "U_CVALR4" coefficients found in the uncertainty coefficients. Using the first encountered.')
- |
-
| 123 | -1x | -
- coefUcrtFdasOfst <- coefUcrtFdasOfst[1]- |
-
| 124 | -- |
- }- |
-
| 125 | -- |
- - |
-
| 126 | -- |
- # Compute FDAS uncertainty- |
-
| 127 | -2x | -
- ucrt$ucrtFdas <-- |
-
| 128 | -2x | -
- (coefUcrtFdas * dataUcrt + coefUcrtFdasOfst) * base::abs(ucrt$dervCal)- |
-
| 129 | -- |
- - |
-
| 130 | -2x | -
- return(ucrt)- |
-
| 131 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Wrapper for computing individual measurement uncertainty for NEON L0' data- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Wrapper function. Compute individual measurement uncertainty for calibrated data at native- |
-
| 9 | -- |
- #' frequency (NEON L0' data).- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Data frame of L0 data. Must include POSIXct time variable readout_time.- |
-
| 12 | -- |
- #' @param FuncUcrt A data frame of the variables for which individual measurement uncertainty is- |
-
| 13 | -- |
- #' to be calculated. Columns include:\cr- |
-
| 14 | -- |
- #' \code{var} Character. The variable in data for which to compute uncertainty \cr
- |
-
| 15 | -- |
- #' \code{FuncUcrtMeas} A character string indicating the individual measurement (calibration) uncertainty
- |
-
| 16 | -- |
- #' function within the NEONprocIS.cal package that should be used. Note that this does not include- |
-
| 17 | -- |
- #' FDAS uncertainty. For most NEON data products, this will be "def.ucrt.meas.cnst". Note that any- |
-
| 18 | -- |
- #' alternative function must accept the same arguments as def.ucrt.meas.cnst, even if they are unused, and- |
-
| 19 | -- |
- #' return the same- |
-
| 20 | -- |
- #' See that function for details. \cr- |
-
| 21 | -- |
- #' \code{FuncUcrtFdas} A character string indicating the FDAS uncertainty function within the NEONprocIS.cal
- |
-
| 22 | -- |
- #' package that should be used, if FDAS uncertainty applies. This field may be NA, which indicates that- |
-
| 23 | -- |
- #' FDAS uncertainty does not apply and will not be calculated (e.g. digital L0 output).- |
-
| 24 | -- |
- #' @param ucrtCoefFdas A data frame of FDAS uncertainty coefficients, as read by- |
-
| 25 | -- |
- #' NEONprocIS.cal::def.read.ucrt.coef.fdas. Columns include:\cr- |
-
| 26 | -- |
- #' \code{Name} Character. Name of the coefficient.\cr
- |
-
| 27 | -- |
- #' \code{Value} Character. Value of the coefficient.\cr
- |
-
| 28 | -- |
- #' \code{.attrs} Character. Relevant attribute (i.e. units)\cr
- |
-
| 29 | -- |
- #' Defaults to NULL, in which case no variables in FuncUcrt may indicate that FDAS uncertainty- |
-
| 30 | -- |
- #' applies.- |
-
| 31 | -- |
- #' @param calSlct A named list of data frames, list element corresponding to the variables in- |
-
| 32 | -- |
- #' FuncUcrt. The data frame in each list element holds information about the calibration files and- |
-
| 33 | -- |
- #' time periods that apply to the variable, as returned from NEONprocIS.cal::def.cal.slct.- |
-
| 34 | -- |
- #' See documentation for that function. Assign NULL to list elements (variables) for which calibration- |
-
| 35 | -- |
- #' information is not applicable (i.e. a function other than def.ucrt.meas.cnst is used to compute its- |
-
| 36 | -- |
- #' uncertainty).- |
-
| 37 | -- |
- #' @param mappNameVar A data frame with in/out variable name mapping as produced by- |
-
| 38 | -- |
- #' NEONprocIS.base::def.var.mapp.in.out. See documentation for that function. If input (default is NULL),- |
-
| 39 | -- |
- #' output variable names will be appended as prefixes to the column names in each output data frame.- |
-
| 40 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 41 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 42 | -- | - - | -
| 43 | -- |
- #' @return A named list, each element corresponding to those in FuncUcrt$var and holding a data- |
-
| 44 | -- |
- #' frame of uncertainty data. Note that each row in each data frame corresponds to the times in- |
-
| 45 | -- |
- #' data$readout_time, but the variable readout_time is not included in the output. One column- |
-
| 46 | -- |
- #' in each data frame is labeled ucrtComb, corresponding to the combined measurement uncertainty- |
-
| 47 | -- |
- #' of the individual measurements and FDAS (if applicable). If FDAS uncertainty does not apply,- |
-
| 48 | -- |
- #' ucrtComb is simply a copy of ucrtMeas. \cr- |
-
| 49 | -- | - - | -
| 50 | -- |
- #' @references Currently none- |
-
| 51 | -- | - - | -
| 52 | -- |
- #' @keywords Currently none- |
-
| 53 | -- | - - | -
| 54 | -- |
- #' @examples Currently none- |
-
| 55 | -- | - - | -
| 56 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.slct}
- |
-
| 57 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 58 | -- |
- #' @seealso \link[NEONprocIS.base]{def.var.mapp.in.out}
- |
-
| 59 | -- | - - | -
| 60 | -- |
- #' @export- |
-
| 61 | -- | - - | -
| 62 | -- |
- # changelog and author contributions / copyrights- |
-
| 63 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 64 | -- |
- # original creation- |
-
| 65 | -- |
- # Mija Choi (2020-08-14)- |
-
| 66 | -- |
- # modified uncertainty function to use, FuncUcrtIdx, by replacing FuncUcrt$ with ParaUcrt$- |
-
| 67 | -- |
- # Cove Sturtevant (2020-08-31)- |
-
| 68 | -- |
- # adjusted calls to uncertainty funcs to conform to new generic format- |
-
| 69 | -- |
- # This includes inputting the entire data frame, the- |
-
| 70 | -- |
- # variable to be generate uncertainty info for, and the (unused) argument calSlct- |
-
| 71 | -- |
- # Changed input to also specify the FDAS uncertainty function to use, instead of- |
-
| 72 | -- |
- # determining it within the code- |
-
| 73 | -- |
- # Changed input argument ParaUcrt to FuncUcrt, and changed input column names to support above changes- |
-
| 74 | -- |
- # Cove Sturtevant (2020-12-09)- |
-
| 75 | -- |
- # removed DirCal from inputs since the calibration path is now included in calSlct- |
-
| 76 | -- |
- ##############################################################################################- |
-
| 77 | -- |
- wrap.ucrt.dp0p <- function(data,- |
-
| 78 | -- |
- FuncUcrt,- |
-
| 79 | -- |
- ucrtCoefFdas=NULL,- |
-
| 80 | -- |
- calSlct,- |
-
| 81 | -- |
- mappNameVar=NULL,- |
-
| 82 | -- |
- log=NULL){
- |
-
| 83 | -- |
- # initialize logging if necessary- |
-
| 84 | -4x | -
- if (base::is.null(log)) {
- |
-
| 85 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 86 | -- |
- }- |
-
| 87 | -- |
- - |
-
| 88 | -- |
- # Basic starting info- |
-
| 89 | -4x | -
- timeMeas <- data$readout_time- |
-
| 90 | -- |
- - |
-
| 91 | -- |
- # Initialize- |
-
| 92 | -4x | -
- ucrtData <- base::vector(mode = "list", length = base::length(FuncUcrt$var))- |
-
| 93 | -4x | -
- base::names(ucrtData) <- FuncUcrt$var- |
-
| 94 | -- | - - | -
| 95 | -- |
- # Loop through the variables- |
-
| 96 | -4x | -
- for(idxVar in FuncUcrt$var){
- |
-
| 97 | -- |
- - |
-
| 98 | -- |
- # Determine the individual measurement uncertainty function to use- |
-
| 99 | -4x | -
- FuncUcrtMeasIdx <- base::get(FuncUcrt$FuncUcrtMeas[FuncUcrt$var == idxVar], base::asNamespace("NEONprocIS.cal"))
- |
-
| 100 | -- |
- - |
-
| 101 | -- |
- # Get output variable name- |
-
| 102 | -4x | -
- nameVarUcrtOut <- mappNameVar$nameVarOut[mappNameVar$nameVarIn==idxVar]- |
-
| 103 | -- |
- - |
-
| 104 | -- |
- # Determine whether FDAS uncertainty applies to this variable, and what function- |
-
| 105 | -4x | -
- FuncUcrtFdasIdx <- NULL- |
-
| 106 | -4x | -
- if(!base::is.na(FuncUcrt$FuncUcrtFdas[FuncUcrt$var == idxVar])){
- |
-
| 107 | -4x | -
- FuncUcrtFdasIdx <- base::get(FuncUcrt$FuncUcrtFdas[FuncUcrt$var == idxVar], base::asNamespace("NEONprocIS.cal"))
- |
-
| 108 | -- |
- }- |
-
| 109 | -- | - - | -
| 110 | -- |
- # Run through each selected calibration and apply the uncertainty function for the applicable time period- |
-
| 111 | -4x | -
- calSlctIdx <- calSlct[[idxVar]]- |
-
| 112 | -4x | -
- for(idxRow in base::seq_len(base::nrow(calSlctIdx))){
- |
-
| 113 | -- |
- - |
-
| 114 | -- |
- # What points in the output correspond to this row?- |
-
| 115 | -5x | -
- setCal <- timeMeas >= calSlctIdx$timeBgn[idxRow] & timeMeas < calSlctIdx$timeEnd[idxRow]- |
-
| 116 | -- |
- - |
-
| 117 | -- |
- # If a calibration file is available for this period, open it and get calibration information- |
-
| 118 | -5x | -
- if(!base::is.na(calSlctIdx$file[idxRow])){
- |
-
| 119 | -2x | -
- fileCal <- base::paste0(calSlctIdx$path[idxRow],calSlctIdx$file[idxRow])- |
-
| 120 | -2x | -
- infoCal <- NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE)- |
-
| 121 | -- |
- } else {
- |
-
| 122 | -3x | -
- infoCal <- NULL- |
-
| 123 | -- |
- }- |
-
| 124 | -- |
- - |
-
| 125 | -- |
- # Pass all calibration information and the data to the calibration uncertainty function- |
-
| 126 | -5x | -
- ucrtMeas <- base::do.call(FuncUcrtMeasIdx,args=base::list(data=base::subset(data,subset=setCal,drop=FALSE),- |
-
| 127 | -5x | -
- infoCal=infoCal,- |
-
| 128 | -5x | -
- varUcrt=idxVar,- |
-
| 129 | -5x | -
- calSlct=calSlct,- |
-
| 130 | -5x | -
- log=log))- |
-
| 131 | -- |
- - |
-
| 132 | -- |
- - |
-
| 133 | -- |
- # Compute FDAS uncertainty, if applicable- |
-
| 134 | -5x | -
- if(!base::is.null(FuncUcrtFdasIdx)){
- |
-
| 135 | -- |
- - |
-
| 136 | -- |
- # Add the FDAS uncertainty coefs to those from the cal file- |
-
| 137 | -5x | -
- infoCal$ucrt <- base::rbind(infoCal$ucrt,ucrtCoefFdas,stringsAsFactors=FALSE)- |
-
| 138 | -- |
- - |
-
| 139 | -- |
- # Get applicable FDAS uncertainty- |
-
| 140 | -5x | -
- ucrtFdas <- base::do.call(FuncUcrtFdasIdx,args=base::list(data=base::subset(data,subset=setCal,drop=FALSE),- |
-
| 141 | -5x | -
- infoCal=infoCal,- |
-
| 142 | -5x | -
- varUcrt=idxVar,- |
-
| 143 | -5x | -
- calSlct=calSlct,- |
-
| 144 | -5x | -
- log=log))- |
-
| 145 | -- |
- - |
-
| 146 | -- |
- # Combine with ucrtMeas- |
-
| 147 | -5x | -
- if(base::nrow(ucrtMeas) != base::nrow(ucrtFdas)){
- |
-
| 148 | -! | -
- log$error('Number of rows returned from measurement calibration uncertainty function do not equal that from FDAS uncertainty function. Something is wrong in the code.')
- |
-
| 149 | -! | -
- stop()- |
-
| 150 | -- |
- }- |
-
| 151 | -5x | -
- ucrtMeas <- base::cbind(ucrtMeas,ucrtFdas)- |
-
| 152 | -- |
- }- |
-
| 153 | -- |
- - |
-
| 154 | -- |
- # Put in overall output for this variable- |
-
| 155 | -5x | -
- if(idxRow == 1){
- |
-
| 156 | -- |
- # Initialize the output with our known columns names- |
-
| 157 | -4x | -
- ucrtDataIdx <-- |
-
| 158 | -4x | -
- base::as.data.frame(- |
-
| 159 | -4x | -
- base::matrix(- |
-
| 160 | -4x | -
- data=as.numeric(NA),- |
-
| 161 | -4x | -
- nrow = base::length(timeMeas),- |
-
| 162 | -4x | -
- ncol = base::ncol(ucrtMeas),- |
-
| 163 | -4x | -
- dimnames = base::list(NULL, base::names(ucrtMeas))- |
-
| 164 | -- |
- ),- |
-
| 165 | -4x | -
- stringsAsFactors = FALSE- |
-
| 166 | -- |
- )- |
-
| 167 | -- |
- }- |
-
| 168 | -- |
- # Place this round of uncertainty data in the output- |
-
| 169 | -5x | -
- ucrtDataIdx[setCal,] <- ucrtMeas- |
-
| 170 | -- |
- - |
-
| 171 | -- |
- } # End loop around selected calibrations- |
-
| 172 | -- |
- - |
-
| 173 | -- |
- # Compute combined uncertainty for this variable. This will combine (in quadrature) any and all outputs from the- |
-
| 174 | -- |
- # measurement and fdas uncertainty functions that begin with ucrtMeas or ucrtFdas.- |
-
| 175 | -4x | -
- nameVarUcrtIdx <- base::names(ucrtDataIdx)- |
-
| 176 | -4x | -
- nameVarUcrtComb <- nameVarUcrtIdx[base::substr(nameVarUcrtIdx,1,8) %in% c('ucrtMeas','ucrtFdas')]
- |
-
| 177 | -- |
- - |
-
| 178 | -- |
- # Error check- |
-
| 179 | -4x | -
- if(base::length(nameVarUcrtComb) == 0){
- |
-
| 180 | -! | -
- log$warn(base::paste0('No variables output from the measurement uncertainty function ',
- |
-
| 181 | -! | -
- FuncUcrt$FuncUcrtMeas[FuncUcrt$var == idxVar],- |
-
| 182 | -! | -
- ' or the FDAS uncertainty function ',- |
-
| 183 | -! | -
- FuncUcrt$FuncUcrtFdas[FuncUcrt$var == idxVar],- |
-
| 184 | -! | -
- ' begin with ucrtMeas or ucrtFdas. Combined uncertainty for variable ',- |
-
| 185 | -! | -
- FuncUcrt$var, ' will be NA')- |
-
| 186 | -- |
- )- |
-
| 187 | -! | -
- ucrtDataIdx$ucrtComb <- NA- |
-
| 188 | -- |
- } else {
- |
-
| 189 | -- |
- - |
-
| 190 | -- |
- # Compute combined uncertainty (ucrtMeas and ucrtFdas)- |
-
| 191 | -4x | -
- ucrtDataIdx <- base::cbind(ucrtDataIdx,NEONprocIS.cal::def.ucrt.comb(ucrt=base::subset(ucrtDataIdx,select=nameVarUcrtComb),log=log))- |
-
| 192 | -- |
- - |
-
| 193 | -- |
- }- |
-
| 194 | -- | - - | -
| 195 | -- |
- # Compute expanded uncertainty- |
-
| 196 | -4x | -
- ucrtDataIdx <- base::cbind(ucrtDataIdx,NEONprocIS.cal::def.ucrt.expn(ucrtComb=ucrtDataIdx[['ucrtComb']],log=log))- |
-
| 197 | -- |
- - |
-
| 198 | -- |
- # Append the output variable name as a prefix to each column- |
-
| 199 | -4x | -
- if(!base::is.null(nameVarUcrtOut)){
- |
-
| 200 | -3x | -
- base::names(ucrtDataIdx) <- base::paste0(nameVarUcrtOut,'_',base::names(ucrtDataIdx))- |
-
| 201 | -- |
- }- |
-
| 202 | -- |
- - |
-
| 203 | -- |
- # Place uncertainty for this variable in overall output- |
-
| 204 | -4x | -
- ucrtData[[idxVar]] <- ucrtDataIdx- |
-
| 205 | -- |
- - |
-
| 206 | -- |
- } # End loop around variables for which to compute individual combined measurement uncertainty- |
-
| 207 | -- |
- - |
-
| 208 | -4x | -
- return(ucrtData)- |
-
| 209 | -- |
- - |
-
| 210 | -- |
- }- |
-
| 1 | -- |
- ###################################################################################################- |
-
| 2 | -- |
- #' @title Validate calibration information returned by NEONprocIS.cal::def.read.cal.xml- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Validate the list elements and coefficients expected in the cal and/or ucrt data frames returned- |
-
| 9 | -- |
- #' from NEONprocIS.cal::def.read.cal.xml. Returns True if passes all checks. FALSE otherwise.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 12 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml).- |
-
| 13 | -- |
- #' @param NameList A character vector of names of the minimum list elements in infoCal. Defaults to- |
-
| 14 | -- |
- #' "cal" and "ucrt".- |
-
| 15 | -- |
- #' @param CoefCal A character vector of coefficient names expected to be present in the "Name" column- |
-
| 16 | -- |
- #' of data frame infoCal$cal. Defaults to NULL, which will not check for any expected coefficients.- |
-
| 17 | -- |
- #' @param CoefUcrt A character vector of coefficient names expected to be present in the "Name" column- |
-
| 18 | -- |
- #' of data frame infoCal$ucrt. Defaults to NULL, which will not check for any expected coefficients.- |
-
| 19 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 20 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @return Boolean. True if passes all checks. FALSE otherwise. \cr- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @references Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @keywords Currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @examples Currently none- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @export- |
-
| 33 | -- | - - | -
| 34 | -- |
- # changelog and author contributions / copyrights- |
-
| 35 | -- |
- # Cove Sturtevant (2010-02-04)- |
-
| 36 | -- |
- # initial creation- |
-
| 37 | -- |
- ##############################################################################################- |
-
| 38 | -- | - - | -
| 39 | -- |
- def.validate.info.cal <- function(infoCal,- |
-
| 40 | -- |
- NameList=c('cal','ucrt'),
- |
-
| 41 | -- |
- CoefCal=NULL,- |
-
| 42 | -- |
- CoefUcrt=NULL,- |
-
| 43 | -- |
- log=NULL) {
- |
-
| 44 | -- |
- # Initialize logging if necessary- |
-
| 45 | -116x | -
- if (base::is.null(log)) {
- |
-
| 46 | -! | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 47 | -- |
- }- |
-
| 48 | -- |
- - |
-
| 49 | -116x | -
- a <- TRUE- |
-
| 50 | -- | - - | -
| 51 | -116x | -
- if (!base::is.list(infoCal) || (base::is.data.frame(infoCal))) {
- |
-
| 52 | -2x | -
- a <- FALSE- |
-
| 53 | -2x | -
- log$error('Input "infoCal" must be a list.')
- |
-
| 54 | -- |
- - |
-
| 55 | -114x | -
- } else if (!base::all(NameList %in% base::names(infoCal)) ) {
- |
-
| 56 | -! | -
- a <- FALSE- |
-
| 57 | -! | -
- log$error(base::paste0('Input "infoCal" must contain (at a minimum) list elements ',base::paste0(NameList,collapse=',')))
- |
-
| 58 | -- |
- - |
-
| 59 | -114x | -
- } else if ('cal' %in% NameList && !base::is.data.frame(infoCal$cal)) {
- |
-
| 60 | -! | -
- a <- FALSE- |
-
| 61 | -! | -
- log$error('List element infoCal$cal must be a data frame.')
- |
-
| 62 | -- |
- - |
-
| 63 | -114x | -
- } else if ('ucrt' %in% NameList && !base::is.data.frame(infoCal$ucrt)) {
- |
-
| 64 | -! | -
- a <- FALSE- |
-
| 65 | -! | -
- log$error('List element infoCal$ucrt must be a data frame.')
- |
-
| 66 | -- |
- - |
-
| 67 | -114x | -
- } else if ('cal' %in% NameList && !base::all(c('Name','Value') %in% base::names(infoCal$cal))) {
- |
-
| 68 | -! | -
- a <- FALSE- |
-
| 69 | -! | -
- log$error('The data frame contained in "infoCal$cal" must have columns "Name" and "Value"')
- |
-
| 70 | -- | - - | -
| 71 | -114x | -
- } else if ('ucrt' %in% NameList && !base::all(c('Name','Value') %in% base::names(infoCal$ucrt))) {
- |
-
| 72 | -! | -
- a <- FALSE- |
-
| 73 | -! | -
- log$error('The data frame contained in "infoCal$ucrt" must have columns "Name" and "Value"')
- |
-
| 74 | -- |
- - |
-
| 75 | -114x | -
- } else if (!base::is.null(CoefCal) && !base::all(CoefCal %in% infoCal$cal$Name)) {
- |
-
| 76 | -! | -
- a <- FALSE- |
-
| 77 | -! | -
- log$error(base::paste0('Missing at least one expected coefficient (',base::paste0(CoefCal,collapse=','),') in "infoCal$cal"'))
- |
-
| 78 | -- |
- - |
-
| 79 | -114x | -
- } else if (!base::is.null(CoefUcrt) && !base::all(CoefUcrt %in% infoCal$ucrt$Name)) {
- |
-
| 80 | -6x | -
- a <- FALSE- |
-
| 81 | -6x | -
- log$error(base::paste0('Missing at least one expected coefficient (',base::paste0(CoefUcrt,collapse=','),') in "infoCal$ucrt"'))
- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- }- |
-
| 84 | -- | - - | -
| 85 | -116x | -
- return (a)- |
-
| 86 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Wrapper for applying calibration conversion to NEON L0 data- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Wrapper function. Apply calibration conversion function to NEON L0 data, thus generating NEON- |
-
| 9 | -- |
- #' L0' data.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Data frame of L0 data. Must include POSIXct time variable readout_time.- |
-
| 12 | -- |
- #' @param calSlct A named list of data frames, list element corresponding to calibrated terms.- |
-
| 13 | -- |
- #' The data frame in each list element holds- |
-
| 14 | -- |
- #' information about the calibration files and time periods that apply to the variable, as returned- |
-
| 15 | -- |
- #' from NEONprocIS.cal::def.cal.slct. See documentation for that function.- |
-
| 16 | -- |
- #' @param FuncConv A data frame of the terms/variables to convert and the function to convert- |
-
| 17 | -- |
- #' them with. Columns include:\cr- |
-
| 18 | -- |
- #' \code{var} Character. The variable in data to apply calibration to. If this variable does not
- |
-
| 19 | -- |
- #' exist in the data, it must be created by the associated calibration function in FuncConv. \cr- |
-
| 20 | -- |
- #' \code{FuncConv} A character string indicating the calibration conversion function
- |
-
| 21 | -- |
- #' within the NEONprocIS.cal package that should be used. For most NEON data products, this will be- |
-
| 22 | -- |
- #' "def.cal.conv.poly". Note that any alternative function must accept the same arguments as- |
-
| 23 | -- |
- #' def.cal.conv.poly, even if they are unused. See that function for details.- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @return A data frame of the converted (calibrated) L0' data, limited to the variables in FuncConv.- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @references Currently none- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @keywords Currently none- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @examples Currently none- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.slct}
- |
-
| 36 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 37 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly}
- |
-
| 38 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.func.poly}
- |
-
| 39 | -- | - - | -
| 40 | -- |
- #' @export- |
-
| 41 | -- | - - | -
| 42 | -- |
- # changelog and author contributions / copyrights- |
-
| 43 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 44 | -- |
- # original creation- |
-
| 45 | -- |
- # Cove Sturtevant (2020-08-31)- |
-
| 46 | -- |
- # adjusted calls to cal funcs to conform to new generic format- |
-
| 47 | -- |
- # This includes inputting the entire data frame, the- |
-
| 48 | -- |
- # variable to be calibrated, and the (unused) argument calSlct- |
-
| 49 | -- |
- # Cove Sturtevant (2020-12-09)- |
-
| 50 | -- |
- # removed DirCal from inputs since the calibration path is now included in calSlct- |
-
| 51 | -- |
- ##############################################################################################- |
-
| 52 | -- |
- wrap.cal.conv <- function(data,- |
-
| 53 | -- |
- calSlct,- |
-
| 54 | -- |
- FuncConv,- |
-
| 55 | -- |
- log=NULL){
- |
-
| 56 | -- |
- # initialize logging if necessary- |
-
| 57 | -3x | -
- if (base::is.null(log)) {
- |
-
| 58 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 59 | -- |
- }- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # Basic starting info- |
-
| 62 | -3x | -
- timeMeas <- data$readout_time- |
-
| 63 | -- |
- - |
-
| 64 | -- |
- # Initialize- |
-
| 65 | -3x | -
- varData <- base::names(data)- |
-
| 66 | -3x | -
- varExst <- base::intersect(FuncConv$var,varData)- |
-
| 67 | -3x | -
- dataConv <- base::subset(data,select=varExst)- |
-
| 68 | -3x | -
- dataConv[] <- NA- |
-
| 69 | -- |
- # Tack on any newly created variables to the end- |
-
| 70 | -3x | -
- varNew <- base::setdiff(FuncConv$var,varData)- |
-
| 71 | -3x | -
- if(base::length(varNew) > 0){
- |
-
| 72 | -! | -
- dataConv[[varNew]] <- base::as.numeric(NA)- |
-
| 73 | -- |
- }- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- # Loop through variables- |
-
| 76 | -3x | -
- for(idxVarCal in FuncConv$var){
- |
-
| 77 | -- |
- - |
-
| 78 | -3x | -
- log$debug(base::paste0('Applying calibration to term: ',idxVarCal))
- |
-
| 79 | -- |
- - |
-
| 80 | -3x | -
- calSlctIdx <- calSlct[[idxVarCal]]- |
-
| 81 | -- | - - | -
| 82 | -- |
- # Run through each selected calibration and apply the calibration function for the applicable time period- |
-
| 83 | -3x | -
- for(idxRow in base::seq_len(base::nrow(calSlctIdx))){
- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # What points in the output correspond to this row?- |
-
| 86 | -3x | -
- setCal <- timeMeas >= calSlctIdx$timeBgn[idxRow] & timeMeas < calSlctIdx$timeEnd[idxRow]- |
-
| 87 | -- |
- - |
-
| 88 | -- |
- # If a calibration file is available for this period, open it and get calibration information- |
-
| 89 | -3x | -
- if(!base::is.na(calSlctIdx$file[idxRow])){
- |
-
| 90 | -2x | -
- fileCal <- base::paste0(calSlctIdx$path[idxRow],calSlctIdx$file[idxRow])- |
-
| 91 | -2x | -
- infoCal <- NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE,log=log)- |
-
| 92 | -- |
- } else {
- |
-
| 93 | -1x | -
- infoCal <- NULL- |
-
| 94 | -- |
- }- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- # Determine the calibration function to use- |
-
| 97 | -3x | -
- FuncConvIdx <- base::get(FuncConv$FuncConv[FuncConv$var == idxVarCal], base::asNamespace("NEONprocIS.cal"))
- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- # Pass the the calibration information to the calibration function- |
-
| 100 | -3x | -
- dataConv[setCal,idxVarCal] <- base::do.call(FuncConvIdx,args=base::list(data=base::subset(data,subset=setCal,drop=FALSE),- |
-
| 101 | -3x | -
- infoCal=infoCal,- |
-
| 102 | -3x | -
- varConv=idxVarCal,- |
-
| 103 | -3x | -
- calSlct=calSlct,- |
-
| 104 | -3x | -
- log=log)- |
-
| 105 | -- |
- )- |
-
| 106 | -- |
- }- |
-
| 107 | -- |
- - |
-
| 108 | -- |
- }- |
-
| 109 | -- |
- - |
-
| 110 | -3x | -
- return(dataConv)- |
-
| 111 | -- |
- - |
-
| 112 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Create calibration polynomial function from NEON CVAL coefficients- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Creates a polynomical object of the calibration function from NEON- |
-
| 9 | -- |
- #' calibration coefficients (from e.g. NEONprocIS.cal::def.read.cal.xml).- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 12 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml). Included in this list must be infoCal$cal, which is- |
-
| 13 | -- |
- #' a data frame of uncertainty coefficents. Columns of this data frame are:\cr- |
-
| 14 | -- |
- #' \code{Name} String. The name of the coefficient. \cr
- |
-
| 15 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 16 | -- |
- #' @param Prfx String. The prefix for the polynomial coefficients. Default is 'CVALA', indicating- |
-
| 17 | -- |
- #' that the polynomial coefficients will follow the convention CVALA0, CVALA1, CVALA2, etc., where- |
-
| 18 | -- |
- #' the number indicates the polynomial power CVALA0 + CVALA1x + CVALA2x^2...- |
-
| 19 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 20 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @return A polynomial (model) object of the polynomial calibration function- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @references- |
-
| 25 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @keywords Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @examples- |
-
| 30 | -- |
- #' infoCal <- list(cal=data.frame(Name=c('CVALA1','CVALA0'),Value=c(10,1),stringsAsFactors=FALSE))
- |
-
| 31 | -- |
- #' def.cal.func.poly(infoCal=infoCal)- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 34 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly}
- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @export- |
-
| 37 | -- | - - | -
| 38 | -- |
- # changelog and author contributions / copyrights- |
-
| 39 | -- |
- # Cove Sturtevant (2020-01-31)- |
-
| 40 | -- |
- # original creation- |
-
| 41 | -- |
- # Cove Sturtevant (2020-07-28)- |
-
| 42 | -- |
- # add options for different calibration coefficient prefixes- |
-
| 43 | -- |
- ##############################################################################################- |
-
| 44 | -- |
- def.cal.func.poly <- function(infoCal,- |
-
| 45 | -- |
- Prfx='CVALA',- |
-
| 46 | -- |
- log = NULL) {
- |
-
| 47 | -- |
- # initialize logging if necessary- |
-
| 48 | -18x | -
- if (base::is.null(log)) {
- |
-
| 49 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 50 | -- |
- }- |
-
| 51 | -- | - - | -
| 52 | -- |
- # Validate calibration information- |
-
| 53 | -18x | -
- if (!NEONprocIS.cal::def.validate.info.cal (infoCal,NameList='cal',log=log)) {
- |
-
| 54 | -1x | -
- stop()- |
-
| 55 | -- |
- }- |
-
| 56 | -- |
- - |
-
| 57 | -- |
- # Reduce cal coefficients to ones we recognize- |
-
| 58 | -17x | -
- cal <- infoCal$cal- |
-
| 59 | -17x | -
- cal <- cal[grep(base::paste0(Prfx,'[0-9]'), cal$Name), ]- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # Error out if there aren't any calibration coefficients- |
-
| 62 | -17x | -
- if(base::nrow(cal) == 0){
- |
-
| 63 | -1x | -
- log$error('No polynomial calibration coefficients found in infoCal')
- |
-
| 64 | -1x | -
- stop()- |
-
| 65 | -- |
- }- |
-
| 66 | -- |
- - |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Pull out the numeric polynomial level of each coefficient (a0,a1,a2,...)- |
-
| 69 | -16x | -
- levlPoly <-- |
-
| 70 | -16x | -
- base::as.numeric(base::unlist(base::lapply(- |
-
| 71 | -16x | -
- base::strsplit(cal$Name, Prfx, fixed = TRUE),- |
-
| 72 | -16x | -
- FUN = function(vect) {
- |
-
| 73 | -42x | -
- vect[2]- |
-
| 74 | -- |
- }- |
-
| 75 | -- |
- )))- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- # Initialize vector of polynomial coefficients (a0,a1,a2,...)- |
-
| 78 | -16x | -
- coefPoly <- base::rep(0, base::max(levlPoly) + 1)- |
-
| 79 | -- |
- - |
-
| 80 | -- |
- # Place the polynomial coefficients in the right place in our coefficient vector- |
-
| 81 | -16x | -
- coefPoly[levlPoly + 1] <- base::as.numeric(cal$Value)- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- # Create polynomial function from coefficients- |
-
| 84 | -16x | -
- func <- polynom::polynomial(coef = coefPoly)- |
-
| 85 | -- |
- - |
-
| 86 | -- |
- # Return the polynomial object- |
-
| 87 | -16x | -
- return(func)- |
-
| 88 | -- |
- - |
-
| 89 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Wrapper for computing calibration flags for all variables and time ranges- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Wrapper function. Compute valid calibration and suspect calibration flags for NEON L0 data.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param data Data frame of L0 data. Must include POSIXct time variable readout_time.- |
-
| 11 | -- |
- #' @param calSlct A named list of data frames, list element corresponding to the variable for which- |
-
| 12 | -- |
- #' uncertainty coefficients are to be compiled. The data frame in each list element holds- |
-
| 13 | -- |
- #' information about the calibration files and time periods that apply to the variable, as returned- |
-
| 14 | -- |
- #' from NEONprocIS.cal::def.cal.slct. See documentation for that function.- |
-
| 15 | -- |
- #' @param mappNameVar A data frame with in/out variable name mapping as produced by- |
-
| 16 | -- |
- #' NEONprocIS.base::def.var.mapp.in.out. See documentation for that function.- |
-
| 17 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 18 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @return A named list of qfExpi and qfSusp, each holding data frames with the same dimension as data,- |
-
| 21 | -- |
- #' with the exception that the variable readout_time is removed.\cr- |
-
| 22 | -- |
- #' \code{qfExpi} Integer. The expired/valid calibration flag. 0 = valid, non expired calibration available;
- |
-
| 23 | -- |
- #' 1 = no calibration or expired calibration available. \cr- |
-
| 24 | -- |
- #' \code{qfSusp} Integer. The suspect calibration flag. 0 = calibration not suspect, 1 = calibration suspect,
- |
-
| 25 | -- |
- #' -1 = no cal to evaluate- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @references Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @keywords Currently none- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @examples Currently none- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.slct}
- |
-
| 34 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 35 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.qf.cal.susp}
- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @export- |
-
| 38 | -- | - - | -
| 39 | -- |
- # changelog and author contributions / copyrights- |
-
| 40 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 41 | -- |
- # original creation- |
-
| 42 | -- |
- # Cove Sturtevant (2020-12-09)- |
-
| 43 | -- |
- # removed DirCal from inputs since the calibration path is now included in calSlct- |
-
| 44 | -- |
- ##############################################################################################- |
-
| 45 | -- |
- wrap.qf.cal <- function(data,- |
-
| 46 | -- |
- calSlct,- |
-
| 47 | -- |
- mappNameVar=NULL,- |
-
| 48 | -- |
- log=NULL){
- |
-
| 49 | -- |
- # initialize logging if necessary- |
-
| 50 | -2x | -
- if (base::is.null(log)) {
- |
-
| 51 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 52 | -- |
- }- |
-
| 53 | -- |
- - |
-
| 54 | -- |
- # Basic starting info- |
-
| 55 | -2x | -
- timeMeas <- data$readout_time- |
-
| 56 | -2x | -
- varQf <- base::intersect(base::names(data),base::names(calSlct))- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # Initialize output- |
-
| 59 | -2x | -
- qfExpi <- base::subset(data,select=varQf); # Initialize flag output- |
-
| 60 | -2x | -
- qfExpi[] <- 1 # Initialize to "expired calibration or no valid calibration available"- |
-
| 61 | -2x | -
- qfSusp <- qfExpi # Initialize flag output- |
-
| 62 | -2x | -
- qfSusp[] <- -1 # Initialize to "cannot evaluate"- |
-
| 63 | -- |
- - |
-
| 64 | -- | - - | -
| 65 | -- |
- # Run through each variable- |
-
| 66 | -2x | -
- for(idxVar in varQf){
- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Run through each selected calibration and apply the flag- |
-
| 69 | -2x | -
- calSlctIdx <- calSlct[[idxVar]]- |
-
| 70 | -2x | -
- for(idxRow in base::seq_len(base::nrow(calSlctIdx))){
- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # What points in the output correspond to this row?- |
-
| 73 | -4x | -
- setCal <- timeMeas >= calSlctIdx$timeBgn[idxRow] & timeMeas < calSlctIdx$timeEnd[idxRow]- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- # If the cal is not expired, populate valid calibration flag as having a valid calibration- |
-
| 76 | -4x | -
- if(!calSlctIdx$expi[idxRow]){
- |
-
| 77 | -1x | -
- qfExpi[[idxVar]][setCal] <- 0- |
-
| 78 | -- |
- }- |
-
| 79 | -- |
- - |
-
| 80 | -- |
- # If no calibration file is available for this period, move on. (Suspect cal already set to -1.)- |
-
| 81 | -4x | -
- if(base::is.na(calSlctIdx$file[idxRow])){
- |
-
| 82 | -2x | -
- next- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # We have a calibration file to open- |
-
| 86 | -2x | -
- fileCal <- base::paste0(calSlctIdx$path[idxRow],calSlctIdx$file[idxRow])- |
-
| 87 | -2x | -
- infoCal <- NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE)- |
-
| 88 | -- |
- - |
-
| 89 | -- |
- # Populate suspect calibration flag- |
-
| 90 | -2x | -
- qfSusp[[idxVar]][setCal] <- NEONprocIS.cal::def.qf.cal.susp(data=data[setCal,idxVar],infoCal=infoCal,log=log)- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- }- |
-
| 93 | -- |
- - |
-
| 94 | -- |
- }- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- # Ensure the output is integer- |
-
| 97 | -2x | -
- qfExpi <- base::lapply(qfExpi,base::as.integer)- |
-
| 98 | -2x | -
- qfSusp <- base::lapply(qfSusp,base::as.integer)- |
-
| 99 | -- |
- - |
-
| 100 | -- |
- # Map input column names to output column names- |
-
| 101 | -2x | -
- qfExpi <- NEONprocIS.base::def.df.renm(qfExpi,mappNameVar=mappNameVar,log=log)- |
-
| 102 | -2x | -
- qfSusp <- NEONprocIS.base::def.df.renm(qfSusp,mappNameVar=mappNameVar,log=log)- |
-
| 103 | -- |
- - |
-
| 104 | -2x | -
- return(base::list(qfExpi=qfExpi,qfSusp=qfSusp))- |
-
| 105 | -- |
- - |
-
| 106 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Individual measurement uncertainty for dissolved oxygen (DO) concentration (mg/L) as part of the water- |
-
| 3 | -- |
- #' quality data product- |
-
| 4 | -- | - - | -
| 5 | -- |
- #' @author- |
-
| 6 | -- |
- #' Kaelin Cawley \email{kcawley@battelleecology.org}
- |
-
| 7 | -- | - - | -
| 8 | -- |
- #' @description Alternative calibration uncertainty function. Create file (dataframe) with- |
-
| 9 | -- |
- #' uncertainty information based off of the L0 dissolved oxygen (DO) concentration data values- |
-
| 10 | -- |
- #' according to NEON.DOC.004931 - NEON Algorithm Theoretical Basis Document (ATBD): Water Quality.- |
-
| 11 | -- |
- #'- |
-
| 12 | -- |
- #' Note: This script implements logging described in \code{\link[NEONprocIS.base]{def.log.init}},
- |
-
| 13 | -- |
- #' which uses system environment variables if available.- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 16 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 17 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml). Included in this list must be infoCal$ucrt, which is- |
-
| 18 | -- |
- #' a data frame of uncertainty coefficents. Columns of this data frame are:\cr- |
-
| 19 | -- |
- #' \code{Name} String. The name of the coefficient. \cr
- |
-
| 20 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 21 | -- |
- #' @param varUcrt A character string of the target variable (column) in the data frame \code{data}
- |
-
| 22 | -- |
- #' that represents Dissolved oxygen (DO) concentration data. Note that for other- |
-
| 23 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame, so long as the function- |
-
| 24 | -- |
- #' knows that. Defaults to the first column in \code{data}.
- |
-
| 25 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 26 | -- |
- #' NEONprocIS.cal::wrap.ucrt.dp0p for what this input is.- |
-
| 27 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 28 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 29 | -- |
- #' created and used within the function.- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @return A data frame with the following variables:\cr- |
-
| 32 | -- |
- #' \code{ucrtMeas} - combined measurement uncertainty for an individual L0 reading.
- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @export- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @references- |
-
| 37 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @keywords Currently none- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @examples- |
-
| 42 | -- |
- #' #Written to potentially plug in to def.cal.conv.R- |
-
| 43 | -- |
- #' ucrt <- def.ucrt.wq.do.conc(data = data, cal = NULL)- |
-
| 44 | -- | - - | -
| 45 | -- |
- #' @seealso None currently- |
-
| 46 | -- | - - | -
| 47 | -- |
- # changelog and author contributions / copyrights- |
-
| 48 | -- |
- # Kaelin Cawley (2020-01-23)- |
-
| 49 | -- |
- # original creation- |
-
| 50 | -- |
- # Cove Sturtevant (2020-09-02)- |
-
| 51 | -- |
- # adjusted inputs to conform to new generic format- |
-
| 52 | -- |
- # This includes inputting the entire data frame, the- |
-
| 53 | -- |
- # variable to be generate uncertainty info for, and the (unused) argument calSlct- |
-
| 54 | -- |
- ##############################################################################################- |
-
| 55 | -- |
- def.ucrt.wq.do.conc <- function(data = data.frame(data=base::numeric(0)),- |
-
| 56 | -- |
- infoCal = NULL,- |
-
| 57 | -- |
- varUcrt = base::names(data)[1],- |
-
| 58 | -- |
- calSlct=NULL,- |
-
| 59 | -- |
- log = NULL) {
- |
-
| 60 | -- |
- # Start logging, if needed- |
-
| 61 | -2x | -
- if (is.null(log)) {
- |
-
| 62 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 63 | -- |
- }- |
-
| 64 | -- |
- - |
-
| 65 | -- |
- # Ensure input is data frame with the target variable in it- |
-
| 66 | -2x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varUcrt,TestEmpty=FALSE, log = log)- |
-
| 67 | -2x | -
- if (!chk) {
- |
-
| 68 | -1x | -
- stop()- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # Check data input is numeric- |
-
| 72 | -1x | -
- if (!NEONprocIS.base::def.validate.vector(data[[varUcrt]],TestEmpty = FALSE, TestNumc = TRUE, log=log)) {
- |
-
| 73 | -! | -
- stop()- |
-
| 74 | -- |
- }- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- #The cal input is not needed for this function- |
-
| 77 | -- |
- #It's just a placeholder input to allow the calibration module to be more generic- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- #Create the output dataframe- |
-
| 80 | -1x | -
- dataUcrt <- data[[varUcrt]] # Target variable to compute uncertainty for- |
-
| 81 | -1x | -
- outputNames <- c("ucrtPercent", "ucrtMeas")
- |
-
| 82 | -1x | -
- outputDF <-- |
-
| 83 | -1x | -
- base::as.data.frame(base::matrix(- |
-
| 84 | -1x | -
- nrow = length(dataUcrt),- |
-
| 85 | -1x | -
- ncol = length(outputNames),- |
-
| 86 | -1x | -
- data = NA- |
-
| 87 | -- |
- ),- |
-
| 88 | -1x | -
- stringsAsFactors = FALSE)- |
-
| 89 | -1x | -
- names(outputDF) <- outputNames- |
-
| 90 | -1x | -
- log$debug('Output dataframe for dissolvedOxygenConcUnc created.')
- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- #Create an output dataframe with U_CVALA1 based off of the following rules:- |
-
| 93 | -- |
- ### U_CVALA1 = 0.01 if DO is > 0 & <= 20 mg/l according to the manual- |
-
| 94 | -- |
- ### U_CVALA1 = 0.05 if DO is >20 mg/l & < 50 mg/l according to the manual- |
-
| 95 | -1x | -
- outputDF$ucrtPercent[dataUcrt <= 20] <-- |
-
| 96 | -1x | -
- 0.01- |
-
| 97 | -1x | -
- log$debug('Low range DO uncertainty populated.')
- |
-
| 98 | -- |
- - |
-
| 99 | -1x | -
- outputDF$ucrtPercent[dataUcrt > 20] <-- |
-
| 100 | -1x | -
- 0.05- |
-
| 101 | -1x | -
- log$debug('High range DO uncertainty populated.')
- |
-
| 102 | -- |
- - |
-
| 103 | -- |
- #Determine uncertainty factor- |
-
| 104 | -1x | -
- outputDF$ucrtMeas <- outputDF$ucrtPercent * dataUcrt- |
-
| 105 | -- |
- - |
-
| 106 | -1x | -
- return(outputDF)- |
-
| 107 | -- |
- - |
-
| 108 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read NEON calibration XML file- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read in a NEON calibration XML file.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param NameFile String. Name (including relative or absolute path) of calibration file.- |
-
| 11 | -- |
- #' @param Vrbs (Optional) Logical. If TRUE, returns the full contents of the calibration file as an additional output.- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 14 | -- | - - | -
| 15 | -- |
- - |
-
| 16 | -- |
- #' @return A named list:\cr- |
-
| 17 | -- |
- #' timeVali = a list of POSIXct valid start & end date-times for the calibration- |
-
| 18 | -- |
- #' cal = a data frame of calibration coefficients- |
-
| 19 | -- |
- #' ucrt = a data frame of uncertainty coefficients- |
-
| 20 | -- |
- #' file = a list of the contents of the full calibration file. Only returned if Vrbs = TRUE.- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @references Currently none- |
-
| 23 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 24 | -- | - - | -
| 25 | -- |
- #' @keywords Currently none- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @examples Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @seealso Currently none- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @export- |
-
| 32 | -- | - - | -
| 33 | -- |
- # changelog and author contributions / copyrights- |
-
| 34 | -- |
- # Cove Sturtevant (2019-02-25)- |
-
| 35 | -- |
- # original creation- |
-
| 36 | -- |
- # Mija Choi (2020-03-03)- |
-
| 37 | -- |
- # Added xml validation- |
-
| 38 | -- |
- # Mija Choi (2020-03-25)- |
-
| 39 | -- |
- # Modified to add a read-only file, inst/extdata/calibration.xsd, in NEONprocIS.cal package- |
-
| 40 | -- |
- # Cove Sturtevant (2020-09-21)- |
-
| 41 | -- |
- # added logging- |
-
| 42 | -- |
- ##############################################################################################- |
-
| 43 | -- |
- def.read.cal.xml <- function(NameFile,Vrbs=TRUE,log=NULL){
- |
-
| 44 | -- |
- - |
-
| 45 | -- |
- # initialize logging if necessary- |
-
| 46 | -120x | -
- if (base::is.null(log)) {
- |
-
| 47 | -51x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 48 | -- |
- }- |
-
| 49 | -- |
- - |
-
| 50 | -- |
- # Check the file against the expected schema. THis issues logs only, because- |
-
| 51 | -- |
- # although a file may fail a schema check, it may still have the info we need.- |
-
| 52 | -120x | -
- xsd1 <- system.file("extdata", "calibration.xsd", package = "NEONprocIS.cal")
- |
-
| 53 | -120x | -
- xmlchk <- try(NEONprocIS.base::def.validate.xml.schema(NameFile, xsd1),silent = TRUE)- |
-
| 54 | -- |
- - |
-
| 55 | -- |
- # Read contents of xml file- |
-
| 56 | -120x | -
- xml <- try(XML::xmlParse(NameFile),silent=TRUE)- |
-
| 57 | -120x | -
- if(class(xml)[1] == "try-error") {
- |
-
| 58 | -4x | -
- log$error(base::paste0("Calibration XML file: ",NameFile," does not exist or is unreadable"))
- |
-
| 59 | -4x | -
- base::stop()- |
-
| 60 | -- |
- }- |
-
| 61 | -- |
- - |
-
| 62 | -- |
- # XML file as a list- |
-
| 63 | -116x | -
- listXml <- XML::xmlToList(xml)- |
-
| 64 | -- |
- - |
-
| 65 | -- |
- # Grab valid date range- |
-
| 66 | -116x | -
- timeVali <- base::lapply(listXml$ValidTimeRange,as.POSIXct,format='%Y-%m-%dT%H:%M:%OS',tz="GMT")- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Grab calibration coefficients and turn into a data frame- |
-
| 69 | -116x | -
- idxCal <- base::which(base::names(listXml$StreamCalVal) == "CalibrationCoefficient")- |
-
| 70 | -116x | -
- coefCal <- base::Reduce(base::rbind,lapply(listXml$StreamCalVal[idxCal],- |
-
| 71 | -116x | -
- base::as.data.frame,stringsAsFactors=FALSE))- |
-
| 72 | -- | - - | -
| 73 | -- |
- # Grab uncertainty coefficients and turn into a data frame- |
-
| 74 | -116x | -
- idxUcrt <- base::which(base::names(listXml$StreamCalVal) == "Uncertainty")- |
-
| 75 | -116x | -
- coefUcrt <- base::Reduce(base::rbind,lapply(listXml$StreamCalVal[idxUcrt],- |
-
| 76 | -116x | -
- base::as.data.frame,stringsAsFactors=FALSE))- |
-
| 77 | -- | - - | -
| 78 | -116x | -
- if (Vrbs == TRUE){
- |
-
| 79 | -116x | -
- rpt <- base::list(timeVali=timeVali,cal=coefCal,ucrt=coefUcrt,file=listXml)- |
-
| 80 | -- |
- } else {
- |
-
| 81 | -! | -
- rpt <- base::list(timeVali=timeVali,cal=coefCal,ucrt=coefUcrt)- |
-
| 82 | -- |
- }- |
-
| 83 | -- |
- - |
-
| 84 | -116x | -
- return(rpt)- |
-
| 85 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compute uncertainty attributed to NEON FDAS voltage measurements (and CVALA polynomial calibration conversion)- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Computes L0' uncertainty imposed by a NEON field data acquisition system (FDAS)- |
-
| 9 | -- |
- #' when making voltage measurements and using a polynomial calibration conversion function with CVALA- |
-
| 10 | -- |
- #' coefficients.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param data Data frame of raw measurements. Note that the column/variable indicated in varUcrt must be numeric.- |
-
| 13 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 14 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml). Included in this list must be infoCal$cal and info$ucrt,- |
-
| 15 | -- |
- #' which are data frames of calibration coefficients and uncertainty coeffcients, respectively.- |
-
| 16 | -- |
- #' Columns of these data frames are:\cr- |
-
| 17 | -- |
- #' \code{Name} String. The name of the coefficient. \cr
- |
-
| 18 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 19 | -- |
- #' @param varUcrt A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 20 | -- |
- #' which FDAS uncertainty data will be computed (all other columns will be ignored). Note that for other- |
-
| 21 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame, so long as the function- |
-
| 22 | -- |
- #' knows that. Defaults to the first column in \code{data}.
- |
-
| 23 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 24 | -- |
- #' NEONprocIS.cal::wrap.ucrt.dp0p for what this input is.- |
-
| 25 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 26 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 27 | -- |
- #' created and used within the function.- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @return A data frame with the following variables:\cr- |
-
| 30 | -- |
- #' \code{ucrt$raw} - raw reading value (i.e. same as input data)\cr
- |
-
| 31 | -- |
- #' \code{ucrt$dervCal} - 1st derivative of calibration function evaluated at raw reading value (e.g. partial derivative
- |
-
| 32 | -- |
- #' of a radiation measurement with respect to the voltage reading)\cr- |
-
| 33 | -- |
- #' \code{ucrt$ucrtFdas} - standard uncertainty of individual measurement introduced by the Field DAS \cr
- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @references- |
-
| 36 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 37 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @keywords Currently none- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @examples Currently none- |
-
| 42 | -- | - - | -
| 43 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.func.poly}
- |
-
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 45 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.ucrt.dp0p}
- |
-
| 46 | -- | - - | -
| 47 | -- |
- #' @export- |
-
| 48 | -- | - - | -
| 49 | -- |
- # changelog and author contributions / copyrights- |
-
| 50 | -- |
- # Cove Sturtevant (2020-02-04)- |
-
| 51 | -- |
- # original creation- |
-
| 52 | -- |
- # Cove Sturtevant (2020-05-12)- |
-
| 53 | -- |
- # Bug fix - allow code to produce NAs if infoCal$cal is NULL but infoCal$ucrt is not NULL- |
-
| 54 | -- |
- # Cove Sturtevant (2020-09-02)- |
-
| 55 | -- |
- # adjusted inputs to conform to new generic format- |
-
| 56 | -- |
- # This includes inputting the entire data frame, the- |
-
| 57 | -- |
- # variable to be generate uncertainty info for, and the (unused) argument calSlct- |
-
| 58 | -- |
- ##############################################################################################- |
-
| 59 | -- |
- def.ucrt.fdas.volt.poly <- function(data = data.frame(data=base::numeric(0)),- |
-
| 60 | -- |
- infoCal = NULL,- |
-
| 61 | -- |
- varUcrt = base::names(data)[1],- |
-
| 62 | -- |
- calSlct=NULL,- |
-
| 63 | -- |
- log = NULL) {
- |
-
| 64 | -- |
- # initialize logging if necessary- |
-
| 65 | -7x | -
- if (base::is.null(log)) {
- |
-
| 66 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 67 | -- |
- }- |
-
| 68 | -- |
- - |
-
| 69 | -- |
- # Ensure input is data frame with the target variable in it- |
-
| 70 | -7x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varUcrt,TestEmpty=FALSE, log = log)- |
-
| 71 | -7x | -
- if (!chk) {
- |
-
| 72 | -! | -
- stop()- |
-
| 73 | -- |
- }- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- # Check data input is numeric- |
-
| 76 | -7x | -
- if (!NEONprocIS.base::def.validate.vector(data[[varUcrt]],TestEmpty = FALSE, TestNumc = TRUE, log=log)) {
- |
-
| 77 | -! | -
- stop()- |
-
| 78 | -- |
- }- |
-
| 79 | -- |
- - |
-
| 80 | -- |
- # Initialize uncertainty output- |
-
| 81 | -7x | -
- dataUcrt <- data[[varUcrt]] # Target variable to compute uncertainty for- |
-
| 82 | -7x | -
- ucrt <-- |
-
| 83 | -7x | -
- base::data.frame(raw = dataUcrt,- |
-
| 84 | -7x | -
- dervCal = NA * dataUcrt,- |
-
| 85 | -7x | -
- ucrtFdas = NA * dataUcrt)- |
-
| 86 | -- |
- - |
-
| 87 | -- |
- # If infoCal is NULL, return NA data- |
-
| 88 | -7x | -
- if (base::is.null(infoCal$cal)) {
- |
-
| 89 | -4x | -
- log$debug('No calibration information supplied, returning NA values for FDAS uncertainty.')
- |
-
| 90 | -4x | -
- return(ucrt)- |
-
| 91 | -- |
- }- |
-
| 92 | -- |
- - |
-
| 93 | -- |
- # Check format of infoCal- |
-
| 94 | -3x | -
- if (!NEONprocIS.cal::def.validate.info.cal(infoCal,- |
-
| 95 | -3x | -
- CoefUcrt = c('U_CVALV1', 'U_CVALV4'),
- |
-
| 96 | -3x | -
- log = log)) {
- |
-
| 97 | -1x | -
- stop()- |
-
| 98 | -- |
- }- |
-
| 99 | -- |
- - |
-
| 100 | -- |
- - |
-
| 101 | -- |
- # Compute derivative of calibration function- |
-
| 102 | -2x | -
- func <- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal,Prfx='CVALA',log=log)- |
-
| 103 | -2x | -
- funcDerv <- stats::deriv(func)- |
-
| 104 | -2x | -
- ucrt$dervCal <-- |
-
| 105 | -2x | -
- stats::predict(object = funcDerv, newdata = dataUcrt) # Eval derivative at each measurement- |
-
| 106 | -- |
- - |
-
| 107 | -- |
- # Retrieve the uncertainty coefficients for voltage measurements- |
-
| 108 | -- |
- # Combined, relative FDAS uncertainty of an individual measurement (U_CVALV1, unitless).- |
-
| 109 | -2x | -
- coefUcrtFdas <-- |
-
| 110 | -2x | -
- base::as.numeric(infoCal$ucrt$Value[infoCal$ucrt$Name == "U_CVALV1"])- |
-
| 111 | -- |
- - |
-
| 112 | -- |
- # Check that we have only 1 coefficient to apply- |
-
| 113 | -2x | -
- if(base::length(coefUcrtFdas) > 1){
- |
-
| 114 | -2x | -
- log$warn('Multiple "U_CVALV1" coefficients found in the uncertainty coefficients. Using the first encountered.')
- |
-
| 115 | -2x | -
- coefUcrtFdas <- coefUcrtFdas[1]- |
-
| 116 | -- |
- }- |
-
| 117 | -- |
- - |
-
| 118 | -- |
- # Offset imposed by the FDAS, in units of voltage (U_CVALV4)- |
-
| 119 | -2x | -
- coefUcrtFdasOfst <-- |
-
| 120 | -2x | -
- base::as.numeric(infoCal$ucrt$Value[infoCal$ucrt$Name == "U_CVALV4"])- |
-
| 121 | -- |
- - |
-
| 122 | -- |
- # Check that we have only 1 coefficient to apply- |
-
| 123 | -2x | -
- if(base::length(coefUcrtFdasOfst) > 1){
- |
-
| 124 | -1x | -
- log$warn('Multiple "U_CVALV4" coefficients found in the uncertainty coefficients. Using the first encountered.')
- |
-
| 125 | -1x | -
- coefUcrtFdasOfst <- coefUcrtFdasOfst[1]- |
-
| 126 | -- |
- }- |
-
| 127 | -- |
- - |
-
| 128 | -- |
- # Compute FDAS uncertainty- |
-
| 129 | -2x | -
- ucrt$ucrtFdas <-- |
-
| 130 | -2x | -
- (coefUcrtFdas * dataUcrt + coefUcrtFdasOfst) * base::abs(ucrt$dervCal)- |
-
| 131 | -- |
- - |
-
| 132 | -2x | -
- return(ucrt)- |
-
| 133 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compute individual measurement calibration uncertainty as a multiplier with NEON CVAL coefficient U_CVALA1- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Accepts L0 data and NEON uncertainty information as produced- |
-
| 9 | -- |
- #' by NEONprocIS.cal::def.read.cal.xml and returns a vector of individual measurement- |
-
| 10 | -- |
- #' uncertainties for each data value. The uncertainty computed is the L0 value multipled by- |
-
| 11 | -- |
- #' NEON calibration uncertainty coefficient U_CVALA1.- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 14 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 15 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml). Included in this list must be infoCal$ucrt, which is- |
-
| 16 | -- |
- #' a data frame of uncertainty coefficents. Columns of this data frame are:\cr- |
-
| 17 | -- |
- #' \code{Name} String. The name of the coefficient. \cr
- |
-
| 18 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 19 | -- |
- #' @param varUcrt A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 20 | -- |
- #' which uncertainty data will be computed (all other columns will be ignored). Note that for other- |
-
| 21 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame, so long as the function- |
-
| 22 | -- |
- #' knows that. Defaults to the first- |
-
| 23 | -- |
- #' column in \code{data}.
- |
-
| 24 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 25 | -- |
- #' NEONprocIS.cal::wrap.ucrt.dp0p for what this input is.- |
-
| 26 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 27 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 28 | -- |
- #' created and used within the function.- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @return A data frame with the following variables:\cr- |
-
| 31 | -- |
- #' \code{ucrtMeas} - combined measurement uncertainty for an individual reading. Includes the
- |
-
| 32 | -- |
- #' repeatability and reproducibility of the sensor and the lab DAS and uncertainty of the- |
-
| 33 | -- |
- #' calibration procedures and coefficients including uncertainty in the standard (truth).- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @references- |
-
| 36 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 37 | -- |
- #' NEON.DOC.000785 TIS Level 1 Data products Uncertainty Budget Estimation Plan- |
-
| 38 | -- |
- #' NEON.DOC.000746 Calibration Fixture and Sensor Uncertainty Analysis: CVAL 2014 Uncertainty Manual- |
-
| 39 | -- | - - | -
| 40 | -- |
- #' @keywords calibration, uncertainty, L0'- |
-
| 41 | -- | - - | -
| 42 | -- |
- #' @examples- |
-
| 43 | -- |
- #' data <- data.frame(data=c(1,6,7,0,10))- |
-
| 44 | -- |
- #' infoCal <- list(ucrt = data.frame(Name=c('U_CVALA1','U_CVALA3'),Value=c(0.1,5),stringsAsFactors=FALSE))
- |
-
| 45 | -- |
- #' def.ucrt.meas.mult(data=data,infoCal=infoCal)- |
-
| 46 | -- | - - | -
| 47 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 48 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.rstc.poly}
- |
-
| 49 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.volt.poly}
- |
-
| 50 | -- |
- #' @seealso \link[NEONprocIS.base]{def.log.init}
- |
-
| 51 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.ucrt.dp0p}
- |
-
| 52 | -- | - - | -
| 53 | -- |
- #' @export- |
-
| 54 | -- | - - | -
| 55 | -- |
- # changelog and author contributions / copyrights- |
-
| 56 | -- |
- # Cove Sturtevant (2020-02-03)- |
-
| 57 | -- |
- # original creation- |
-
| 58 | -- |
- # Cove Sturtevant (2020-09-02)- |
-
| 59 | -- |
- # adjusted inputs to conform to new generic format- |
-
| 60 | -- |
- # This includes inputting the entire data frame, the- |
-
| 61 | -- |
- # variable to be generate uncertainty info for, and the (unused) argument calSlct- |
-
| 62 | -- |
- ##############################################################################################- |
-
| 63 | -- |
- def.ucrt.meas.mult <- function(data = data.frame(data=base::numeric(0)),- |
-
| 64 | -- |
- infoCal = NULL,- |
-
| 65 | -- |
- varUcrt = base::names(data)[1],- |
-
| 66 | -- |
- calSlct=NULL,- |
-
| 67 | -- |
- log = NULL) {
- |
-
| 68 | -- |
- # Initialize logging if necessary- |
-
| 69 | -4x | -
- if (base::is.null(log)) {
- |
-
| 70 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 71 | -- |
- }- |
-
| 72 | -- |
- - |
-
| 73 | -- |
- # Ensure input is data frame with the target variable in it- |
-
| 74 | -4x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varUcrt,TestEmpty=FALSE, log = log)- |
-
| 75 | -4x | -
- if (!chk) {
- |
-
| 76 | -! | -
- stop()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # Check data input is numeric- |
-
| 80 | -4x | -
- if (!NEONprocIS.base::def.validate.vector(data[[varUcrt]],TestEmpty = FALSE, TestNumc = TRUE, log=log)) {
- |
-
| 81 | -! | -
- stop()- |
-
| 82 | -- |
- }- |
-
| 83 | -- |
- - |
-
| 84 | -- |
- # Initialize output data frame- |
-
| 85 | -4x | -
- dataUcrt <- data[[varUcrt]] # Target variable to compute uncertainty for- |
-
| 86 | -4x | -
- ucrt <- base::data.frame(ucrtMeas = NA * dataUcrt)- |
-
| 87 | -- |
- - |
-
| 88 | -- |
- # If infoCal is NULL, return NA data- |
-
| 89 | -4x | -
- if(base::is.null(infoCal)){
- |
-
| 90 | -1x | -
- log$debug('No calibration information supplied, returning NA values for individual measurement uncertainty.')
- |
-
| 91 | -1x | -
- return(ucrt)- |
-
| 92 | -- |
- }- |
-
| 93 | -- |
- - |
-
| 94 | -- |
- # Check format of infoCal- |
-
| 95 | -3x | -
- if (!NEONprocIS.cal::def.validate.info.cal(infoCal,CoefUcrt='U_CVALA1',log=log)){
- |
-
| 96 | -1x | -
- stop()- |
-
| 97 | -- |
- }- |
-
| 98 | -- |
- - |
-
| 99 | -- |
- # Uncertainty coefficient U_CVALA1 represents the combined measurement uncertainty for an- |
-
| 100 | -- |
- # individual reading. It includes the repeatability and reproducibility of the sensor and the- |
-
| 101 | -- |
- # lab DAS and ii) uncertainty of the calibration procedures and coefficients including- |
-
| 102 | -- |
- # uncertainty in the standard (truth).- |
-
| 103 | -2x | -
- ucrtCoef <- infoCal$ucrt[infoCal$ucrt$Name == 'U_CVALA1',]- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- # Issue warning if more than one matching uncertainty coefficient was found- |
-
| 106 | -2x | -
- if(base::nrow(ucrtCoef) > 1){
- |
-
| 107 | -1x | -
- log$warn("More than one matching uncertainty coefficient was found for U_CVALA1. Using the first.")
- |
-
| 108 | -- |
- }- |
-
| 109 | -- |
- - |
-
| 110 | -- |
- # The individual measurement uncertainty is just U_CVALA1 multiplied by each measurement- |
-
| 111 | -2x | -
- ucrt$ucrtMeas[] <- base::as.numeric(ucrtCoef$Value[1])*dataUcrt- |
-
| 112 | -- |
- - |
-
| 113 | -2x | -
- return(ucrt)- |
-
| 114 | -- |
- - |
-
| 115 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Wrapper for compiling uncertainty coefficients for all variables and time ranges- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Wrapper function. Compute individual measurement uncertainty for calibrated data at native- |
-
| 9 | -- |
- #' frequency (NEON L0' data).- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param calSlct A named list of data frames, list element corresponding to the variable for which- |
-
| 12 | -- |
- #' uncertainty coefficients are to be compiled. The data frame in each list element holds- |
-
| 13 | -- |
- #' information about the calibration files and time periods that apply to the variable, as returned- |
-
| 14 | -- |
- #' from NEONprocIS.cal::def.cal.slct. See documentation for that function.- |
-
| 15 | -- |
- #' @param ucrtCoefFdas A data frame of FDAS uncertainty coefficients, as read by- |
-
| 16 | -- |
- #' NEONprocIS.cal::def.read.ucrt.coef.fdas. Columns include:\cr- |
-
| 17 | -- |
- #' \code{Name} Character. Name of the coefficient.\cr
- |
-
| 18 | -- |
- #' \code{Value} Character. Value of the coefficient.\cr
- |
-
| 19 | -- |
- #' \code{.attrs} Character. Relevant attribute (i.e. units)\cr
- |
-
| 20 | -- |
- #' Defaults to NULL, in which case no FDAS uncertainty coefficients will be combined with calibration- |
-
| 21 | -- |
- #' uncertanty coefs. Conversely, if this argument is present, the FDAS uncertainty coefficients contained- |
-
| 22 | -- |
- #' in this argument will be combined (and output) with calibration uncertianty coefs for all variables.- |
-
| 23 | -- |
- #' @param mappNameVar A data frame with in/out variable name mapping as produced by- |
-
| 24 | -- |
- #' NEONprocIS.base::def.var.mapp.in.out. See documentation for that function. If input (default is- |
-
| 25 | -- |
- #' NULL), input variable names in the output data frames will be replaced by their corresponding- |
-
| 26 | -- |
- #' output name.- |
-
| 27 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 28 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @return A named list, each element corresponding to those in FuncUcrt$var and holding a data- |
-
| 31 | -- |
- #' frame of uncertainty coefficients and applicable time ranges. \cr- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @references Currently none- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @keywords Currently none- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @examples Currently none- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.slct}
- |
-
| 40 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 41 | -- |
- #' @seealso \link[NEONprocIS.base]{def.var.mapp.in.out}
- |
-
| 42 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.ucrt.coef.fdas}
- |
-
| 43 | -- | - - | -
| 44 | -- |
- #' @export- |
-
| 45 | -- | - - | -
| 46 | -- |
- # changelog and author contributions / copyrights- |
-
| 47 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 48 | -- |
- # original creation- |
-
| 49 | -- |
- # Cove Sturtevant (2020-12-09)- |
-
| 50 | -- |
- # removed DirCal from inputs since the calibration path is now included in calSlct- |
-
| 51 | -- |
- # Cove Sturtevant (2021-04-01)- |
-
| 52 | -- |
- # fix bug that deleted the directory path to the cal file before all cal files were read in- |
-
| 53 | -- |
- ##############################################################################################- |
-
| 54 | -- |
- wrap.ucrt.coef <- function(calSlct,- |
-
| 55 | -- |
- ucrtCoefFdas=NULL,- |
-
| 56 | -- |
- mappNameVar=NULL,- |
-
| 57 | -- |
- log=NULL){
- |
-
| 58 | -- |
- # initialize logging if necessary- |
-
| 59 | -2x | -
- if (base::is.null(log)) {
- |
-
| 60 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 61 | -- |
- }- |
-
| 62 | -- |
- - |
-
| 63 | -- |
- # Initialize output- |
-
| 64 | -2x | -
- varCal <- base::names(calSlct)- |
-
| 65 | -2x | -
- ucrtCoef <- base::vector(mode = "list", length = length(varCal)) # Initialize- |
-
| 66 | -2x | -
- base::names(ucrtCoef) <- varCal- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Loop around variables- |
-
| 69 | -2x | -
- for(idxVar in varCal){
- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # Grab the L0' term for this L0 variable- |
-
| 72 | -4x | -
- idxVarOut <- mappNameVar$nameVarOut[mappNameVar$nameVarIn==idxVar]- |
-
| 73 | -- |
- - |
-
| 74 | -- |
- # Get the list of selected calibrations and applicable time periods- |
-
| 75 | -4x | -
- calSlctIdx <- calSlct[[idxVar]]- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- # Run through each selected calibration & grab the coefficients- |
-
| 78 | -4x | -
- ucrtCoefIdx <- base::vector(mode = "list", length = base::nrow(calSlctIdx))- |
-
| 79 | -4x | -
- for(idxRow in base::seq_len(base::nrow(calSlctIdx))){
- |
-
| 80 | -- |
- - |
-
| 81 | -- |
- # If no calibration file is available for this period, move on. (No coefficients to compile)- |
-
| 82 | -6x | -
- if(base::is.na(calSlctIdx$file[idxRow])){
- |
-
| 83 | -2x | -
- next- |
-
| 84 | -- |
- }- |
-
| 85 | -- |
- - |
-
| 86 | -- |
- # We have a calibration file to open- |
-
| 87 | -4x | -
- fileCal <- base::paste0(calSlctIdx$path[idxRow],calSlctIdx$file[idxRow])- |
-
| 88 | -4x | -
- infoCal <- NEONprocIS.cal::def.read.cal.xml(NameFile=fileCal,Vrbs=TRUE)- |
-
| 89 | -- |
- - |
-
| 90 | -- |
- # Add in FDAS uncertainty- |
-
| 91 | -4x | -
- if(!base::is.null(ucrtCoefFdas)){
- |
-
| 92 | -- |
- # Add the applicable FDAS uncertainty coefs to those from the cal file- |
-
| 93 | -4x | -
- infoCal$ucrt <- base::rbind(infoCal$ucrt,ucrtCoefFdas,stringsAsFactors=FALSE)- |
-
| 94 | -- |
- }- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- # Add in cal metadata to the coefs, excluding the directory path- |
-
| 97 | -4x | -
- infoCal$ucrt$id <- calSlctIdx$id[idxRow]- |
-
| 98 | -4x | -
- if(!base::is.null(idxVarOut)){
- |
-
| 99 | -2x | -
- infoCal$ucrt$var <- idxVarOut- |
-
| 100 | -- |
- } else {
- |
-
| 101 | -2x | -
- infoCal$ucrt$var <- idxVar- |
-
| 102 | -- |
- }- |
-
| 103 | -4x | -
- ucrtCoefIdx[[idxRow]] <- base::merge(x=calSlctIdx[idxRow,!(names(calSlctIdx) %in% 'path')],y=infoCal$ucrt,by='id')- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- } # End loop around selected calibrations- |
-
| 106 | -- |
- - |
-
| 107 | -- |
- # Combine coefs for all selected calibrations for this variable- |
-
| 108 | -4x | -
- ucrtCoef[[idxVar]] <- base::Reduce(f=base::rbind,x=ucrtCoefIdx)- |
-
| 109 | -- |
- - |
-
| 110 | -- |
- } # End loop around variables- |
-
| 111 | -- |
- - |
-
| 112 | -2x | -
- return(ucrtCoef)- |
-
| 113 | -- |
- - |
-
| 114 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Convert raw to calibrated data using NEON CVALB polynomial calibration coefficients- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Apply NEON calibration polynomial function contained in coefficients- |
-
| 9 | -- |
- #' CVALB0, CVALB1, CVALB2, etc. to convert raw data to calibrated data.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 12 | -- |
- #' @param infoCal A list of calibration information as returned from NEONprocIS.cal::def.read.cal.xml.- |
-
| 13 | -- |
- #' One list element must be \code{cal}, which is a data frame of polynomial calibration coefficients.
- |
-
| 14 | -- |
- #' This data frame must include columns:\cr- |
-
| 15 | -- |
- #' \code{Name} String. The name of the coefficient. Must fit regular expression CVALB[0-9]\cr
- |
-
| 16 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 17 | -- |
- #' Defaults to NULL, in which case converted data will be retured as NA.- |
-
| 18 | -- |
- #' @param varConv A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 19 | -- |
- #' which the calibration will be applied (all other columns will be ignored). Note that for other- |
-
| 20 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame. Defaults to the first- |
-
| 21 | -- |
- #' column in \code{data}.
- |
-
| 22 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 23 | -- |
- #' NEONprocIS.cal::wrap.cal.conv for what this input is.- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 26 | -- |
- #' created and used within the function.- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @return A Numeric vector of calibrated data\cr- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @references- |
-
| 31 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 32 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @keywords Currently none- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @examples- |
-
| 37 | -- |
- #' data=data.frame(data=c(1,2,3))- |
-
| 38 | -- |
- #' infoCal <- data.frame(Name=c('CVALB1','CVALB0'),Value=c(10,1),stringsAsFactors=FALSE)
- |
-
| 39 | -- |
- #' def.cal.conv.poly.b(data=data,infoCal=infoCal)- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 42 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly}
- |
-
| 43 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.m}
- |
-
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.cal.conv}
- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @export- |
-
| 47 | -- | - - | -
| 48 | -- |
- # changelog and author contributions / copyrights- |
-
| 49 | -- |
- # Cove Sturtevant (2020-07-28)- |
-
| 50 | -- |
- # original creation, from def.cal.conv.poly- |
-
| 51 | -- |
- # Cove Sturtevant (2020-08-31)- |
-
| 52 | -- |
- # adjusted inputs to conform to new generic format for all cal funcs- |
-
| 53 | -- |
- # This includes inputting the entire data frame, the- |
-
| 54 | -- |
- # variable to be calibrated, and the (unused) argument calSlct- |
-
| 55 | -- |
- ##############################################################################################- |
-
| 56 | -- |
- def.cal.conv.poly.b <- function(data = data.frame(data=base::numeric(0)),- |
-
| 57 | -- |
- infoCal = NULL,- |
-
| 58 | -- |
- varConv = base::names(data)[1],- |
-
| 59 | -- |
- calSlct=NULL,- |
-
| 60 | -- |
- log = NULL) {
- |
-
| 61 | -- |
- # Intialize logging if needed- |
-
| 62 | -4x | -
- if (base::is.null(log)) {
- |
-
| 63 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 64 | -- |
- }- |
-
| 65 | -- | - - | -
| 66 | -- |
- # Ensure input is data frame- |
-
| 67 | -4x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varConv,TestEmpty=FALSE, log = log)- |
-
| 68 | -4x | -
- if (!chk) {
- |
-
| 69 | -2x | -
- stop()- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Check to see if data to be calibrated is a numeric array- |
-
| 73 | -2x | -
- chk <-- |
-
| 74 | -2x | -
- NEONprocIS.base::def.validate.vector(data[[varConv]], TestEmpty = FALSE, TestNumc = TRUE, log = log)- |
-
| 75 | -2x | -
- if (!chk) {
- |
-
| 76 | -! | -
- stop()- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # If infoCal is NULL, return NA data- |
-
| 80 | -2x | -
- if (is.null(infoCal)) {
- |
-
| 81 | -1x | -
- log$warn('No calibration information supplied, returning NA values for converted data.')
- |
-
| 82 | -1x | -
- dataConv <- NA * data[[varConv]]- |
-
| 83 | -1x | -
- return(dataConv)- |
-
| 84 | -- |
- } else {
- |
-
| 85 | -- |
- # Check to see if infoCal is a list- |
-
| 86 | -1x | -
- chkList <-- |
-
| 87 | -1x | -
- NEONprocIS.base::def.validate.list(infoCal, log = log)- |
-
| 88 | -1x | -
- if (!chkList) {
- |
-
| 89 | -! | -
- chk <- c(chk, chkList)- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- }- |
-
| 93 | -- | - - | -
| 94 | -- |
- # Construct the polynomial calibration function- |
-
| 95 | -1x | -
- func <-- |
-
| 96 | -1x | -
- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal, Prfx='CVALB', log = log)- |
-
| 97 | -- |
- - |
-
| 98 | -- |
- # Convert data using the calibration function- |
-
| 99 | -1x | -
- dataConv <- stats::predict(object = func, newdata = data[[varConv]])- |
-
| 100 | -- |
- - |
-
| 101 | -1x | -
- return(dataConv)- |
-
| 102 | -- |
- - |
-
| 103 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Convert raw to calibrated data using NEON CVALA polynomial calibration coefficients- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Apply NEON calibration polynomial function contained in coefficients- |
-
| 9 | -- |
- #' CVALA0, CVALA1, CVALA2, etc. to convert raw data to calibrated data.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 12 | -- |
- #' @param infoCal A list of calibration information as returned from NEONprocIS.cal::def.read.cal.xml.- |
-
| 13 | -- |
- #' One list element must be \code{cal}, which is a data frame of polynomial calibration coefficients.
- |
-
| 14 | -- |
- #' This data frame must include columns:\cr- |
-
| 15 | -- |
- #' \code{Name} String. The name of the coefficient. Must fit regular expression CVALA[0-9]\cr
- |
-
| 16 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 17 | -- |
- #' Defaults to NULL, in which case converted data will be retured as NA.- |
-
| 18 | -- |
- #' @param varConv A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 19 | -- |
- #' which calibrated output will be computed (all other columns will be ignored). Note that for other- |
-
| 20 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame. Defaults to the first- |
-
| 21 | -- |
- #' column in \code{data}.
- |
-
| 22 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 23 | -- |
- #' NEONprocIS.cal::wrap.cal.conv for what this input is.- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 26 | -- |
- #' created and used within the function.- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @return A Numeric vector of calibrated data\cr- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @references- |
-
| 31 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 32 | -- |
- #' NEON.DOC.000785 TIS Calibrated Measurements and Level 1 Data Products Uncertainty Budget Plan- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @keywords Currently none- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @examples- |
-
| 37 | -- |
- #' data=data.frame(data=c(1,2,3))- |
-
| 38 | -- |
- #' infoCal <- data.frame(Name=c('CVALA1','CVALA0'),Value=c(10,1),stringsAsFactors=FALSE)
- |
-
| 39 | -- |
- #' def.cal.conv.poly(data=data,infoCal=infoCal)- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 42 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.b}
- |
-
| 43 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.conv.poly.m}
- |
-
| 44 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.cal.conv}
- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @export- |
-
| 47 | -- | - - | -
| 48 | -- |
- # changelog and author contributions / copyrights- |
-
| 49 | -- |
- # Cove Sturtevant (2019-02-26)- |
-
| 50 | -- |
- # original creation- |
-
| 51 | -- |
- # Cove Sturtevant (2019-10-28)- |
-
| 52 | -- |
- # Added computation of uncertainty information- |
-
| 53 | -- |
- # Mija Choi (2020-01-07)- |
-
| 54 | -- |
- # Added parameter validations and logging- |
-
| 55 | -- |
- # Cove Sturtevant (2020-01-31)- |
-
| 56 | -- |
- # Removed uncertainty quantification (moved to separate function)- |
-
| 57 | -- |
- # Split out creation of the polynomial model object into a function- |
-
| 58 | -- |
- # Mija Choi (2020-02-24)- |
-
| 59 | -- |
- # Added list validations- |
-
| 60 | -- |
- # Cove Sturtevant (2020-05-12)- |
-
| 61 | -- |
- # Bug fix - incorrectly stopping when infoCal is NULL- |
-
| 62 | -- |
- # Cove Sturtevant (2020-07-28)- |
-
| 63 | -- |
- # specify CVALA as the coefficient prefix- |
-
| 64 | -- |
- # Cove Sturtevant (2020-08-31)- |
-
| 65 | -- |
- # adjusted inputs to conform to new generic format for all cal funcs- |
-
| 66 | -- |
- # This includes inputting the entire data frame, the- |
-
| 67 | -- |
- # variable to be calibrated, and the (unused) argument calSlct- |
-
| 68 | -- |
- ##############################################################################################- |
-
| 69 | -- |
- def.cal.conv.poly <- function(data = data.frame(data=base::numeric(0)),- |
-
| 70 | -- |
- infoCal = NULL,- |
-
| 71 | -- |
- varConv = base::names(data)[1],- |
-
| 72 | -- |
- calSlct=NULL,- |
-
| 73 | -- |
- log = NULL) {
- |
-
| 74 | -- |
- # Intialize logging if needed- |
-
| 75 | -6x | -
- if (base::is.null(log)) {
- |
-
| 76 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 77 | -- |
- }- |
-
| 78 | -- | - - | -
| 79 | -- |
- # Ensure input is data frame- |
-
| 80 | -6x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varConv,TestEmpty=FALSE, log = log)- |
-
| 81 | -6x | -
- if (!chk) {
- |
-
| 82 | -! | -
- stop()- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # Check to see if data to be calibrated is a numeric array- |
-
| 86 | -6x | -
- chk <-- |
-
| 87 | -6x | -
- NEONprocIS.base::def.validate.vector(data[[varConv]], TestEmpty = FALSE, TestNumc = TRUE, log = log)- |
-
| 88 | -6x | -
- if (!chk) {
- |
-
| 89 | -! | -
- stop()- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- # If infoCal is NULL, return NA data- |
-
| 93 | -6x | -
- if (is.null(infoCal)) {
- |
-
| 94 | -1x | -
- log$warn('No calibration information supplied, returning NA values for converted data.')
- |
-
| 95 | -1x | -
- dataConv <- NA * data[[varConv]]- |
-
| 96 | -1x | -
- return(dataConv)- |
-
| 97 | -- |
- } else {
- |
-
| 98 | -- |
- # Check to see if infoCal is a list- |
-
| 99 | -5x | -
- chkList <-- |
-
| 100 | -5x | -
- NEONprocIS.base::def.validate.list(infoCal, log = log)- |
-
| 101 | -5x | -
- if (!chkList) {
- |
-
| 102 | -! | -
- chk <- c(chk, chkList)- |
-
| 103 | -- |
- }- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- }- |
-
| 106 | -- | - - | -
| 107 | -- |
- # Construct the polynomial calibration function- |
-
| 108 | -5x | -
- func <-- |
-
| 109 | -5x | -
- NEONprocIS.cal::def.cal.func.poly(infoCal = infoCal, Prfx='CVALA', log = log)- |
-
| 110 | -- |
- - |
-
| 111 | -- |
- # Convert data using the calibration function- |
-
| 112 | -4x | -
- dataConv <- stats::predict(object = func, newdata = data[[varConv]])- |
-
| 113 | -- |
- - |
-
| 114 | -4x | -
- return(dataConv)- |
-
| 115 | -- |
- - |
-
| 116 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Individual measurement uncertainty for temperature from the conductivity sensor as part of the water- |
-
| 3 | -- |
- #' quality data product- |
-
| 4 | -- | - - | -
| 5 | -- |
- #' @author- |
-
| 6 | -- |
- #' Kaelin Cawley \email{kcawley@battelleecology.org}
- |
-
| 7 | -- | - - | -
| 8 | -- |
- #' @description Alternative calibration uncertainty function. Create file (dataframe) with- |
-
| 9 | -- |
- #' uncertainty information based off of the L0 temperature data values from the conductivity sensor- |
-
| 10 | -- |
- #' according to NEON.DOC.004931 - NEON Algorithm Theoretical Basis Document (ATBD): Water Quality.- |
-
| 11 | -- |
- #'- |
-
| 12 | -- |
- #' Note: This script implements logging described in \code{\link[NEONprocIS.base]{def.log.init}},
- |
-
| 13 | -- |
- #' which uses system environment variables if available.- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 16 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 17 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml). Included in this list must be infoCal$ucrt, which is- |
-
| 18 | -- |
- #' a data frame of uncertainty coefficents. Columns of this data frame are:\cr- |
-
| 19 | -- |
- #' \code{Name} String. The name of the coefficient. \cr
- |
-
| 20 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 21 | -- |
- #' @param varUcrt A character string of the target variable (column) in the data frame \code{data}
- |
-
| 22 | -- |
- #' that represents temperature data from the conductivity sensor. Note that for other- |
-
| 23 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame, so long as the function- |
-
| 24 | -- |
- #' knows that. Defaults to the first column in \code{data}.
- |
-
| 25 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 26 | -- |
- #' NEONprocIS.cal::wrap.ucrt.dp0p for what this input is.- |
-
| 27 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 28 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 29 | -- |
- #' created and used within the function.- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @return A data frame with the following variables:\cr- |
-
| 32 | -- |
- #' \code{ucrtMeas} - combined measurement uncertainty for an individual L0 reading.
- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @export- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @references- |
-
| 37 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @keywords Currently none- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @examples- |
-
| 42 | -- |
- #' #Written to potentially plug in to def.cal.conv.R- |
-
| 43 | -- |
- #' ucrt <- def.ucrt.wq.temp.conc(data = data, cal = NULL)- |
-
| 44 | -- | - - | -
| 45 | -- |
- #' @seealso None currently- |
-
| 46 | -- | - - | -
| 47 | -- |
- # changelog and author contributions / copyrights- |
-
| 48 | -- |
- # Kaelin Cawley (2020-03-02)- |
-
| 49 | -- |
- # original creation- |
-
| 50 | -- |
- # Cove Sturtevant (2020-09-02)- |
-
| 51 | -- |
- # adjusted inputs to conform to new generic format- |
-
| 52 | -- |
- # This includes inputting the entire data frame, the- |
-
| 53 | -- |
- # variable to be generate uncertainty info for, and the (unused) argument calSlct- |
-
| 54 | -- |
- ##############################################################################################- |
-
| 55 | -- |
- def.ucrt.wq.temp.conc <- function(data = data.frame(data=base::numeric(0)),- |
-
| 56 | -- |
- infoCal = NULL,- |
-
| 57 | -- |
- varUcrt = base::names(data)[1],- |
-
| 58 | -- |
- calSlct=NULL,- |
-
| 59 | -- |
- log = NULL) {
- |
-
| 60 | -- |
- # Start logging, if needed- |
-
| 61 | -3x | -
- if (is.null(log)) {
- |
-
| 62 | -3x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 63 | -- |
- }- |
-
| 64 | -- |
- - |
-
| 65 | -- |
- # Ensure input is data frame with the target variable in it- |
-
| 66 | -3x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varUcrt,TestEmpty=FALSE, log = log)- |
-
| 67 | -3x | -
- if (!chk) {
- |
-
| 68 | -1x | -
- stop()- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # Check data input is numeric- |
-
| 72 | -2x | -
- if (!NEONprocIS.base::def.validate.vector(data[[varUcrt]],TestEmpty = FALSE, TestNumc = TRUE, log=log)) {
- |
-
| 73 | -! | -
- stop()- |
-
| 74 | -- |
- }- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- #The cal input is not needed for this function- |
-
| 77 | -- |
- #It's just a placeholder input to allow the calibration module to be more generic- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- #Create the output dataframe- |
-
| 80 | -2x | -
- dataUcrt <- data[[varUcrt]] # Target variable to compute uncertainty for- |
-
| 81 | -2x | -
- outputNames <- c("ucrtMeas")
- |
-
| 82 | -2x | -
- outputDF <-- |
-
| 83 | -2x | -
- base::as.data.frame(base::matrix(- |
-
| 84 | -2x | -
- nrow = length(dataUcrt),- |
-
| 85 | -2x | -
- ncol = length(outputNames),- |
-
| 86 | -2x | -
- data = NA- |
-
| 87 | -- |
- ),- |
-
| 88 | -2x | -
- stringsAsFactors = FALSE)- |
-
| 89 | -2x | -
- names(outputDF) <- outputNames- |
-
| 90 | -2x | -
- log$debug('Output dataframe for tempFromCondUnc created.')
- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- #Create an output dataframe with U_CVALA1 based off of the following rules:- |
-
| 93 | -- |
- ### U_CVALA1 = 0.01 if temp is <= 35 Celsius according to the manual- |
-
| 94 | -- |
- ### U_CVALA1 = 0.05 if temp is >35 Celsius according to the manual- |
-
| 95 | -2x | -
- outputDF$ucrtMeas[dataUcrt <= 35] <-- |
-
| 96 | -2x | -
- 0.01- |
-
| 97 | -2x | -
- log$debug('Low range temp uncertainty populated.')
- |
-
| 98 | -- |
- - |
-
| 99 | -2x | -
- outputDF$ucrtMeas[dataUcrt > 35] <-- |
-
| 100 | -2x | -
- 0.05- |
-
| 101 | -2x | -
- log$debug('High range temp uncertainty populated.')
- |
-
| 102 | -- |
- - |
-
| 103 | -2x | -
- return(outputDF)- |
-
| 104 | -- |
- - |
-
| 105 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compute individual measurement calibration uncertainty as a constant from NEON CVAL coefficient U_CVALA1- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Accepts a L0 data vector and NEON uncertainty information as produced- |
-
| 9 | -- |
- #' by NEONprocIS.cal::def.read.cal.xml and returns a vector of individual measurement- |
-
| 10 | -- |
- #' uncertainties for each data value. The uncertainty computed is simply a constant value- |
-
| 11 | -- |
- #' represented by NEON calibration coefficient U_CVALA1.- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @param data Numeric data frame of raw measurements.- |
-
| 14 | -- |
- #' @param infoCal List of calibration and uncertainty information read from a NEON calibration file- |
-
| 15 | -- |
- #' (as from NEONprocIS.cal::def.read.cal.xml). Included in this list must be infoCal$ucrt, which is- |
-
| 16 | -- |
- #' a data frame of uncertainty coefficents. Columns of this data frame are:\cr- |
-
| 17 | -- |
- #' \code{Name} String. The name of the coefficient. \cr
- |
-
| 18 | -- |
- #' \code{Value} String or numeric. Coefficient value. Will be converted to numeric. \cr
- |
-
| 19 | -- |
- #' @param varUcrt A character string of the target variable (column) in the data frame \code{data} for
- |
-
| 20 | -- |
- #' which uncertainty data will be computed (all other columns will be ignored). Note that for other- |
-
| 21 | -- |
- #' uncertainty functions this variable may not need to be in the input data frame, so long as the function- |
-
| 22 | -- |
- #' knows that. Defaults to the first column in \code{data}.
- |
-
| 23 | -- |
- #' @param calSlct Unused in this function. Defaults to NULL. See the inputs to- |
-
| 24 | -- |
- #' NEONprocIS.cal::wrap.ucrt.dp0p for what this input is.- |
-
| 25 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 26 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 27 | -- |
- #' created and used within the function.- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @return A data frame with the following variables:\cr- |
-
| 30 | -- |
- #' \code{ucrtMeas} - combined measurement uncertainty for an individual reading. Includes the
- |
-
| 31 | -- |
- #' repeatability and reproducibility of the sensor and the lab DAS and uncertainty of the- |
-
| 32 | -- |
- #' calibration procedures and coefficients including uncertainty in the standard (truth).- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @references- |
-
| 35 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 36 | -- |
- #' NEON.DOC.000785 TIS Level 1 Data products Uncertainty Budget Estimation Plan- |
-
| 37 | -- |
- #' NEON.DOC.000746 Calibration Fixture and Sensor Uncertainty Analysis: CVAL 2014 Uncertainty Manual- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @keywords calibration, uncertainty- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @examples- |
-
| 42 | -- |
- #' data <- data.frame(data=c(1,6,7,0,10))- |
-
| 43 | -- |
- #' infoCal <- list(ucrt = data.frame(Name=c('U_CVALA1','U_CVALA3'),Value=c(0.1,5),stringsAsFactors=FALSE))
- |
-
| 44 | -- |
- #' def.ucrt.meas.cnst(data=data,infoCal=infoCal)- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 47 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.rstc.poly}
- |
-
| 48 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.volt.poly}
- |
-
| 49 | -- |
- #' @seealso \link[NEONprocIS.base]{def.log.init}
- |
-
| 50 | -- |
- #' @seealso \link[NEONprocIS.cal]{wrap.ucrt.dp0p}
- |
-
| 51 | -- | - - | -
| 52 | -- |
- #' @export- |
-
| 53 | -- | - - | -
| 54 | -- |
- # changelog and author contributions / copyrights- |
-
| 55 | -- |
- # Cove Sturtevant (2020-02-03)- |
-
| 56 | -- |
- # original creation- |
-
| 57 | -- |
- # Cove Sturtevant (2020-09-02)- |
-
| 58 | -- |
- # adjusted inputs to conform to new generic format- |
-
| 59 | -- |
- # This includes inputting the entire data frame, the- |
-
| 60 | -- |
- # variable to be generate uncertainty info for, and the (unused) argument calSlct- |
-
| 61 | -- |
- ##############################################################################################- |
-
| 62 | -- |
- def.ucrt.meas.cnst <- function(data = data.frame(data=base::numeric(0)),- |
-
| 63 | -- |
- infoCal = NULL,- |
-
| 64 | -- |
- varUcrt = base::names(data)[1],- |
-
| 65 | -- |
- calSlct=NULL,- |
-
| 66 | -- |
- log = NULL) {
- |
-
| 67 | -- |
- # Initialize logging if necessary- |
-
| 68 | -9x | -
- if (base::is.null(log)) {
- |
-
| 69 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 70 | -- |
- }- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Ensure input is data frame with the target variable in it- |
-
| 73 | -9x | -
- chk <- NEONprocIS.base::def.validate.dataframe(dfIn=data,TestNameCol=varUcrt,TestEmpty=FALSE, log = log)- |
-
| 74 | -9x | -
- if (!chk) {
- |
-
| 75 | -! | -
- stop()- |
-
| 76 | -- |
- }- |
-
| 77 | -- |
- - |
-
| 78 | -- |
- # Check data input is numeric- |
-
| 79 | -9x | -
- if (!NEONprocIS.base::def.validate.vector(data[[varUcrt]],TestEmpty = FALSE, TestNumc = TRUE, log=log)) {
- |
-
| 80 | -! | -
- stop()- |
-
| 81 | -- |
- }- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- # Initialize output data frame- |
-
| 84 | -9x | -
- dataUcrt <- data[[varUcrt]] # Target variable to compute uncertainty for- |
-
| 85 | -9x | -
- ucrt <- base::data.frame(ucrtMeas = NA * dataUcrt)- |
-
| 86 | -- |
- - |
-
| 87 | -- |
- # If infoCal is NULL, return NA data- |
-
| 88 | -9x | -
- if(base::is.null(infoCal)){
- |
-
| 89 | -4x | -
- log$debug('No calibration information supplied, returning NA values for individual measurement uncertainty.')
- |
-
| 90 | -4x | -
- return(ucrt)- |
-
| 91 | -- |
- }- |
-
| 92 | -- |
- - |
-
| 93 | -- |
- # Check format of infoCal- |
-
| 94 | -5x | -
- if (!NEONprocIS.cal::def.validate.info.cal(infoCal,CoefUcrt='U_CVALA1',log=log)){
- |
-
| 95 | -1x | -
- stop()- |
-
| 96 | -- |
- }- |
-
| 97 | -- |
- - |
-
| 98 | -- |
- # Uncertainty coefficient U_CVALA1 represents the combined measurement uncertainty for an- |
-
| 99 | -- |
- # individual reading. It includes the repeatability and reproducibility of the sensor and the- |
-
| 100 | -- |
- # lab DAS and ii) uncertainty of the calibration procedures and coefficients including- |
-
| 101 | -- |
- # uncertainty in the standard (truth).- |
-
| 102 | -4x | -
- ucrtCoef <- infoCal$ucrt[infoCal$ucrt$Name == 'U_CVALA1',]- |
-
| 103 | -- |
- - |
-
| 104 | -- |
- # Issue warning if more than one matching uncertainty coefficient was found- |
-
| 105 | -4x | -
- if(base::nrow(ucrtCoef) > 1){
- |
-
| 106 | -1x | -
- log$warn("More than one matching uncertainty coefficient was found for U_CVALA1. Using the first.")
- |
-
| 107 | -- |
- }- |
-
| 108 | -- |
- - |
-
| 109 | -- |
- # The individual measurement uncertainty is just U_CVALA1 for each measurement- |
-
| 110 | -4x | -
- ucrt$ucrtMeas[] <- base::as.numeric(ucrtCoef$Value[1])- |
-
| 111 | -- |
- - |
-
| 112 | -4x | -
- return(ucrt)- |
-
| 113 | -- |
- - |
-
| 114 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Wrapper for selecting the applicable calibrations and their time ranges for all variables- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Wrapper function. Select the calibrations and their time ranges that apply for each- |
-
| 9 | -- |
- #' selected variable.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param DirCal Character string. Relative or absolute path (minus file name) to the main calibration- |
-
| 12 | -- |
- #' directory. Nested within this directory are directories for each variable, each holding- |
-
| 13 | -- |
- #' calibration files for that variable. Defaults to "./"- |
-
| 14 | -- |
- #' @param NameVarExpc Character vector of minimum variables for which to supply calibration information- |
-
| 15 | -- |
- #' (even if there are no applicable calibrations). Default to character(0), which will return cal info- |
-
| 16 | -- |
- #' for only the variable directories found in DirCal.- |
-
| 17 | -- |
- #' @param TimeBgn A POSIXct timestamp of the start date of interest (inclusive)- |
-
| 18 | -- |
- #' @param TimeEnd A POSIXct timestamp of the end date of interest (exclusive)- |
-
| 19 | -- |
- #' @param NumDayExpiMax A data frame indicating the max days since expiration that calibration- |
-
| 20 | -- |
- #' information is still considered usable for each variable. Calibrations beyond this allowance period- |
-
| 21 | -- |
- #' are treated as if they do not exist. Columns in this data frame are:\cr- |
-
| 22 | -- |
- #' \code{var} Character. Variable name.\cr
- |
-
| 23 | -- |
- #' \code{NumDayExpiMax} Numeric. Max days after expiration that a calibration is considered usable.\cr
- |
-
| 24 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 25 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @return A named list, each element corresponding to the variables found in the DirCal directory- |
-
| 28 | -- |
- #' and holding a data frame of selected calibrations for the time range of interst as output by- |
-
| 29 | -- |
- #' NEONprocIS.cal::def.cal.slct. See that function for details.- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @references Currently none- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @keywords Currently none- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @examples Currently none- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.slct}
- |
-
| 38 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 39 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.cal.meta}
- |
-
| 40 | -- | - - | -
| 41 | -- | - - | -
| 42 | -- |
- #' @export- |
-
| 43 | -- | - - | -
| 44 | -- |
- # changelog and author contributions / copyrights- |
-
| 45 | -- |
- # Cove Sturtevant (2020-02-13)- |
-
| 46 | -- |
- # original creation- |
-
| 47 | -- |
- ##############################################################################################- |
-
| 48 | -- |
- wrap.cal.slct <- function(DirCal="./",- |
-
| 49 | -- |
- NameVarExpc=character(0),- |
-
| 50 | -- |
- TimeBgn,- |
-
| 51 | -- |
- TimeEnd,- |
-
| 52 | -- |
- NumDayExpiMax,- |
-
| 53 | -- |
- log=NULL){
- |
-
| 54 | -- |
- # initialize logging if necessary- |
-
| 55 | -12x | -
- if (base::is.null(log)) {
- |
-
| 56 | -12x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 57 | -- |
- }- |
-
| 58 | -- |
- - |
-
| 59 | -- |
- # Basic info- |
-
| 60 | -12x | -
- varCal <- base::unique(c(NameVarExpc,base::dir(DirCal)))- |
-
| 61 | -12x | -
- numVarCal <- base::length(varCal)- |
-
| 62 | -- |
- - |
-
| 63 | -- |
- # Intialize- |
-
| 64 | -12x | -
- metaCal <- base::vector(mode = "list", length = numVarCal) # initialize- |
-
| 65 | -12x | -
- base::names(metaCal) <- varCal # initialize- |
-
| 66 | -12x | -
- calSlct <- metaCal # initialize- |
-
| 67 | -- |
- - |
-
| 68 | -- |
- # Loop through variables for which calibration information is supplied- |
-
| 69 | -12x | -
- for(idxVarCal in varCal){
- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # Directory listing of cal files for this data stream- |
-
| 72 | -22x | -
- DirCalVar <- base::paste0(DirCal,'/',idxVarCal)- |
-
| 73 | -22x | -
- fileCal <- base::dir(DirCalVar)- |
-
| 74 | -22x | -
- numCal <- base::length(fileCal)- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Get metadata for all the calibration files in the directory, saving the valid start/end dates & certificate number- |
-
| 77 | -22x | -
- if(numCal > 0){
- |
-
| 78 | -20x | -
- metaCal[[idxVarCal]] <- NEONprocIS.cal::def.cal.meta(fileCal=base::paste0(DirCalVar,'/',fileCal),log=log)- |
-
| 79 | -- |
- } else {
- |
-
| 80 | -2x | -
- metaCal[[idxVarCal]] <- NULL- |
-
| 81 | -- |
- }- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- # Determine the time period for which each calibration file applies (and whether it is expired)- |
-
| 84 | -22x | -
- NumDayExpiMaxIdx <- NumDayExpiMax$NumDayExpiMax[NumDayExpiMax$var == idxVarCal]- |
-
| 85 | -- |
- - |
-
| 86 | -22x | -
- if(base::length(NumDayExpiMaxIdx) == 0 || base::is.na(NumDayExpiMaxIdx)){
- |
-
| 87 | -2x | -
- calSlct[[idxVarCal]] <- NEONprocIS.cal::def.cal.slct(metaCal=metaCal[[idxVarCal]],TimeBgn=TimeBgn,TimeEnd=TimeEnd,TimeExpiMax=NULL)- |
-
| 88 | -- |
- } else {
- |
-
| 89 | -20x | -
- calSlct[[idxVarCal]] <- NEONprocIS.cal::def.cal.slct(metaCal=metaCal[[idxVarCal]],TimeBgn=TimeBgn,TimeEnd=TimeEnd,TimeExpiMax=base::as.difftime(NumDayExpiMaxIdx,units='days'))- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- }- |
-
| 92 | -- |
- - |
-
| 93 | -12x | -
- return(calSlct)- |
-
| 94 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compute expanded measurement uncertainty (95 percent confidence)- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Compute expanded measurement uncertainty at 95 percent confidence from combined- |
-
| 9 | -- |
- #' measurement uncertainty- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param ucrt Numeric data vector of combined measurement uncertainty (1 sigma)- |
-
| 12 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 13 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 14 | -- |
- #' created and used within the function.- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @return A data frame with a single numeric column: \cr- |
-
| 17 | -- |
- #' \code{ucrtExpn} - expanded measurement uncertainty
- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @references- |
-
| 20 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 21 | -- |
- #' NEON.DOC.000785 TIS Level 1 Data products Uncertainty Budget Estimation Plan- |
-
| 22 | -- |
- #' NEON.DOC.000746 Calibration Fixture and Sensor Uncertainty Analysis: CVAL 2014 Uncertainty Manual- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @keywords combined uncertainty- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @examples- |
-
| 27 | -- |
- #' ucrtComb <- c(1,2,1,1,2)- |
-
| 28 | -- |
- #' NEONprocIS.cal::def.ucrt.expn(ucrtComb=ucrtComb)- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.read.cal.xml}
- |
-
| 31 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.rstc.poly}
- |
-
| 32 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.fdas.volt.poly}
- |
-
| 33 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.meas.cnst}
- |
-
| 34 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.meas.mult}
- |
-
| 35 | -- |
- #' @seealso \link[NEONprocIS.cal]{def.ucrt.comb}
- |
-
| 36 | -- |
- #' @seealso \link[NEONprocIS.base]{def.log.init}
- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @export- |
-
| 39 | -- | - - | -
| 40 | -- |
- # changelog and author contributions / copyrights- |
-
| 41 | -- |
- # Cove Sturtevant (2020-02-03)- |
-
| 42 | -- |
- # original creation- |
-
| 43 | -- |
- ##############################################################################################- |
-
| 44 | -- |
- def.ucrt.expn <- function(ucrtComb, log = NULL) {
- |
-
| 45 | -- |
- # Initialize logging if necessary- |
-
| 46 | -6x | -
- if (base::is.null(log)) {
- |
-
| 47 | -2x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 48 | -- |
- }- |
-
| 49 | -- |
- - |
-
| 50 | -- |
- # Error check- |
-
| 51 | -6x | -
- if (!NEONprocIS.base::def.validate.vector(ucrtComb,- |
-
| 52 | -6x | -
- TestEmpty=FALSE,- |
-
| 53 | -6x | -
- TestNumc=TRUE,- |
-
| 54 | -6x | -
- log=log)) {
- |
-
| 55 | -1x | -
- stop()- |
-
| 56 | -- |
- }- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # Compute expanded uncertainty- |
-
| 59 | -5x | -
- ucrtExpn <- ucrtComb*2- |
-
| 60 | -- |
- - |
-
| 61 | -- |
- # Create data frame- |
-
| 62 | -5x | -
- rpt <- base::data.frame(ucrtExpn = ucrtExpn, stringsAsFactors = FALSE)- |
-
| 63 | -- |
- - |
-
| 64 | -5x | -
- return(rpt)- |
-
| 65 | -- |
- - |
-
| 66 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Determine discrete periods a heater was turned on based on heater events- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Determine discrete periods a heater was turned on based on heater events.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param dataHeat Data frame of heater event data as returned by NEONprocIS.base::def.read.evnt.json.R- |
-
| 11 | -- |
- #' At a minimum, column variables include:- |
-
| 12 | -- |
- #' timestamp = POSIX time of heater status- |
-
| 13 | -- |
- #' status = logical (TRUE=heater on)- |
-
| 14 | -- |
- #'- |
-
| 15 | -- |
- #' @param TimeOffAuto A difftime object indicating the timeout period after which to assume the heater- |
-
| 16 | -- |
- #' turned off even though there is no even indicating so (e.g. base::as.difftime(30,units='mins')).- |
-
| 17 | -- |
- #' Default is never (NULL).- |
-
| 18 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 19 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which no logger other than- |
-
| 20 | -- |
- #' standard R error messaging will be used.- |
-
| 21 | -- |
- #'- |
-
| 22 | -- |
- #' @return A data frame of:- |
-
| 23 | -- |
- #' timeOn POSIXct Time heater turned on- |
-
| 24 | -- |
- #' timeOff POSIXct Time heater turned off- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @references- |
-
| 27 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @keywords Currently none- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @examples- |
-
| 32 | -- |
- #' TimeOffAuto <- base::as.difftime(30,units="mins")- |
-
| 33 | -- |
- #' timeOnHeat <- def.heat.time.on(dataHeat,TimeOffAuto=TimeOffAuto)- |
-
| 34 | -- |
- #'- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.log.init}}
- |
-
| 37 | -- |
- #' @seealso \code{\link[NEONprocIS.base]{def.read.evnt.json}}
- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @export- |
-
| 40 | -- | - - | -
| 41 | -- |
- # changelog and author contributions / copyrights- |
-
| 42 | -- |
- # Cove Sturtevant (2019-12-19)- |
-
| 43 | -- |
- # original creation- |
-
| 44 | -- |
- ##############################################################################################- |
-
| 45 | -- |
- def.time.heat.on <- function(dataHeat,- |
-
| 46 | -- |
- TimeOffAuto=NULL,- |
-
| 47 | -- |
- log=NULL- |
-
| 48 | -- |
- ){
- |
-
| 49 | -- |
- - |
-
| 50 | -- |
- # Initialize- |
-
| 51 | -3x | -
- dmmyTime <- base::as.POSIXct(base::numeric(0),origin='1970-01-01',tz='GMT')- |
-
| 52 | -3x | -
- rpt <- base::data.frame(timeOn=dmmyTime,timeOff=dmmyTime,stringsAsFactors = FALSE)- |
-
| 53 | -- |
- - |
-
| 54 | -- |
- # Indices of on/off events- |
-
| 55 | -3x | -
- setHeatOn <- base::which(dataHeat$state == TRUE)- |
-
| 56 | -3x | -
- setHeatOff <- base::which(dataHeat$state == FALSE)- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # No on events- |
-
| 59 | -3x | -
- if(base::length(setHeatOn) == 0){
- |
-
| 60 | -- |
- # Any off events?- |
-
| 61 | -1x | -
- if(base::length(setHeatOff) > 0){
- |
-
| 62 | -1x | -
- timeOnIdx <- base::as.POSIXct(NA)- |
-
| 63 | -1x | -
- idxTimeOff <- setHeatOff[1]- |
-
| 64 | -1x | -
- timeOffIdx <- dataHeat$timestamp[idxTimeOff]- |
-
| 65 | -1x | -
- rpt <- base::rbind(rpt,base::data.frame(timeOn=timeOnIdx,timeOff=timeOffIdx,stringsAsFactors = FALSE))- |
-
| 66 | -- |
- }- |
-
| 67 | -1x | -
- return(rpt)- |
-
| 68 | -- |
- }- |
-
| 69 | -- |
- - |
-
| 70 | -2x | -
- idxTimeOn <- setHeatOn[1]- |
-
| 71 | -2x | -
- flagStop <- FALSE- |
-
| 72 | -2x | -
- while(flagStop == FALSE){
- |
-
| 73 | -- |
- - |
-
| 74 | -- |
- # Time heater turned on for this period- |
-
| 75 | -2x | -
- timeOnIdx <- dataHeat$timestamp[idxTimeOn]- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- # Time heater turned off this period- |
-
| 78 | -2x | -
- idxTimeOff <- utils::head(x=setHeatOff[setHeatOff > idxTimeOn],n=1)- |
-
| 79 | -- |
- - |
-
| 80 | -- |
- # Auto-timeout apply?- |
-
| 81 | -2x | -
- if(!base::is.null(TimeOffAuto)){
- |
-
| 82 | -1x | -
- if(base::length(idxTimeOff) > 0){
- |
-
| 83 | -1x | -
- setOnOff <- idxTimeOn:idxTimeOff # Time off recorded- |
-
| 84 | -- |
- } else {
- |
-
| 85 | -! | -
- setOnOff <- idxTimeOn:utils::tail(x=setHeatOn[setHeatOn >= idxTimeOn],n=1) # Time off not recorded- |
-
| 86 | -- |
- }- |
-
| 87 | -- |
- - |
-
| 88 | -1x | -
- timeDiffOnOff <- diff(dataHeat$timestamp[setOnOff]) # Time differences between set of on & off events for this period- |
-
| 89 | -1x | -
- idxTimeOffAuto <- utils::head(setOnOff[timeDiffOnOff > TimeOffAuto],n=1) # Past the timeout?- |
-
| 90 | -1x | -
- if(base::length(idxTimeOffAuto) > 0){
- |
-
| 91 | -1x | -
- timeOffIdx <- dataHeat$timestamp[idxTimeOffAuto]+TimeOffAuto # Timeout applied- |
-
| 92 | -- |
- } else {
- |
-
| 93 | -! | -
- timeOffIdx <- dataHeat$timestamp[utils::tail(setOnOff,n=1)]- |
-
| 94 | -- |
- }- |
-
| 95 | -- |
- } else {
- |
-
| 96 | -- |
- # No timeout applies- |
-
| 97 | -1x | -
- if(base::length(idxTimeOff) > 0){
- |
-
| 98 | -1x | -
- timeOffIdx <- dataHeat$timestamp[idxTimeOff] # use time of 'off' event- |
-
| 99 | -- |
- } else {
- |
-
| 100 | -! | -
- timeOffIdx <- base::as.POSIXct(NA) # Still on!- |
-
| 101 | -- |
- }- |
-
| 102 | -- |
- }- |
-
| 103 | -- |
- - |
-
| 104 | -- |
- - |
-
| 105 | -- |
- # if(base::length(idxTimeOff) > 0){
- |
-
| 106 | -- |
- #- |
-
| 107 | -- |
- # # Last time it was reported on before turning off- |
-
| 108 | -- |
- # #idxTimeOnLast <- utils::tail(x=setHeatOn[setHeatOn >= idxTimeOn & setHeatOn < idxTimeOff],n=1)- |
-
| 109 | -- |
- #- |
-
| 110 | -- |
- # # Auto-timeout apply?- |
-
| 111 | -- |
- # if(!base::is.null(TimeOffAuto){
- |
-
| 112 | -- |
- # setOnOff <- idxTimeOn:idxTimeOff- |
-
| 113 | -- |
- # timeDiffOnOff <- diff(dataHeat$timestamp[setOnOff])- |
-
| 114 | -- |
- # idxTimeOffAuto <- utils::head(setOnOff[timeDiffOnOff > TimeOffAuto],n=1)- |
-
| 115 | -- |
- # timeOffIdx <- dataHeat$timestamp[idxTimeOffAuto]+TimeOffAuto # Timeout applied- |
-
| 116 | -- |
- # } else {
- |
-
| 117 | -- |
- # timeOffIdx <- dataHeat$timestamp[idxTimeOff] # use time of 'off' event- |
-
| 118 | -- |
- # }- |
-
| 119 | -- |
- # } else {
- |
-
| 120 | -- |
- #- |
-
| 121 | -- |
- # # No off time recorded.- |
-
| 122 | -- |
- #- |
-
| 123 | -- |
- # # Last time it was reported on- |
-
| 124 | -- |
- # setOnOff <- idxTimeOn:utils::tail(x=setHeatOn[setHeatOn >= idxTimeOn],n=1)- |
-
| 125 | -- |
- # #idxTimeOnLast <- utils::tail(x=setHeatOn[setHeatOn >= idxTimeOn],n=1)- |
-
| 126 | -- |
- #- |
-
| 127 | -- |
- # # Auto-timeout apply?- |
-
| 128 | -- |
- # if(!is.null(TimeOffAuto)){
- |
-
| 129 | -- |
- # timeOffIdx <- dataHeat$timestamp[idxTimeOnLast]+TimeOffAuto # Timeout applied- |
-
| 130 | -- |
- # } else {
- |
-
| 131 | -- |
- # timeOffIdx <- base::as.POSIXct(NA) # Still on!- |
-
| 132 | -- |
- # }- |
-
| 133 | -- |
- # }- |
-
| 134 | -- |
- - |
-
| 135 | -- |
- # Record- |
-
| 136 | -2x | -
- rpt <- base::rbind(rpt,base::data.frame(timeOn=timeOnIdx,timeOff=timeOffIdx,stringsAsFactors = FALSE))- |
-
| 137 | -- |
- - |
-
| 138 | -- |
- # Reset beginning index- |
-
| 139 | -2x | -
- idxTimeOn <- utils::head(x=setHeatOn[dataHeat$timestamp[setHeatOn] > timeOffIdx],n=1)- |
-
| 140 | -- |
- - |
-
| 141 | -2x | -
- if(base::length(idxTimeOn) == 0){
- |
-
| 142 | -2x | -
- flagStop=TRUE- |
-
| 143 | -- |
- }- |
-
| 144 | -- |
- - |
-
| 145 | -2x | -
- } # End while loop- |
-
| 146 | -- |
- - |
-
| 147 | -2x | -
- return(rpt)- |
-
| 148 | -- | - - | -
| 149 | -- |
- - |
-
| 150 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Determine set of applicable QA/QC thresholds for date, location, term, and context- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Given a json file of thresholds, return those that are applicable to the- |
-
| 9 | -- |
- #' date, term (variable), and context (all properties of the thresholds). The choice of- |
-
| 10 | -- |
- #' constraint/threshold to use is determined by moving up the following hierarchy- |
-
| 11 | -- |
- #' from finer to coarser constraints until one applies. Thus, the finest applicable level of constraint- |
-
| 12 | -- |
- #' is chosen. Threshold selection order is as follows (1 being the finest possible contraint):- |
-
| 13 | -- |
- #' 6. Realm, annual- |
-
| 14 | -- |
- #' 5. Realm, seasonal- |
-
| 15 | -- |
- #' 4. Site-specific, annual- |
-
| 16 | -- |
- #' 3. Site-specific, seasonal- |
-
| 17 | -- |
- #' 2. Sensor-spefific, annual- |
-
| 18 | -- |
- #' 1. Sensor-specific, seasonal- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @param thsh List of thresholds, as returned from NEONprocIS.qaqc::def.read.thsh.qaqc.list- |
-
| 21 | -- |
- #' @param Time POSIXct value of the day to select thresholds for (assumes time resolution- |
-
| 22 | -- |
- #' for thresholds is 1 day). Time should be at 00:00:00 GMT- |
-
| 23 | -- |
- #' @param Term Character value. The term for which to select thresholds for.- |
-
| 24 | -- |
- #' @param Ctxt Character vector (optional) . The contexts for which to select thresholds for. Treated- |
-
| 25 | -- |
- #' as an AND with \code{Term}, meaning that the thresholds are selected which match both the Term
- |
-
| 26 | -- |
- #' and all contexts. Defaults to NULL, in which case the criteria for threshold selection is limited- |
-
| 27 | -- |
- #' to the term.- |
-
| 28 | -- |
- #' @param Site Character value. The NEON site code. (e.g. HARV). If NULL (default), the REALM- |
-
| 29 | -- |
- #' thresholds will be selected.- |
-
| 30 | -- |
- #' @param NameLoc Character value. The specific named location of the sensor. If NULL (default),- |
-
| 31 | -- |
- #' the REALM thresholds will be selected.- |
-
| 32 | -- |
- #' @param RptThsh Logical value. If TRUE, the filtered list of thresholds is output. If FALSE, the- |
-
| 33 | -- |
- #' indices of the selected thresholds in the input list is returned. Defaults to TRUE.- |
-
| 34 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 35 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 36 | -- |
- #' created and used within the function.- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @return If the RptThsh argument is TRUE, the filtered (selected) list of thresholds is output- |
-
| 39 | -- |
- #' in the same format as input \code{thsh}. If RptThsh is false, the indices of the selected
- |
-
| 40 | -- |
- #' thresholds in the input list \code{thsh} is returned.
- |
-
| 41 | -- | - - | -
| 42 | -- |
- #' @references- |
-
| 43 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 44 | -- | - - | -
| 45 | -- |
- #' @keywords quality control, quality assurance, QA/QC, QA/QC test- |
-
| 46 | -- |
- #'- |
-
| 47 | -- |
- #' @examples- |
-
| 48 | -- |
- #' Currently none- |
-
| 49 | -- | - - | -
| 50 | -- |
- #' @seealso \link[NEONprocIS.qaqc]{def.read.thsh.qaqc.df}
- |
-
| 51 | -- |
- #' @seealso \link[NEONprocIS.qaqc]{def.read.thsh.qaqc.list}
- |
-
| 52 | -- | - - | -
| 53 | -- |
- #' @export- |
-
| 54 | -- | - - | -
| 55 | -- |
- # changelog and author contributions / copyrights- |
-
| 56 | -- |
- # Cove Sturtevant (2020-03-14)- |
-
| 57 | -- |
- # original creation- |
-
| 58 | -- |
- ##############################################################################################- |
-
| 59 | -- |
- def.thsh.slct <- function(thsh,- |
-
| 60 | -- |
- Time,- |
-
| 61 | -- |
- Term,- |
-
| 62 | -- |
- Ctxt = NULL,- |
-
| 63 | -- |
- Site=NULL,- |
-
| 64 | -- |
- NameLoc=NULL,- |
-
| 65 | -- |
- RptThsh = TRUE,- |
-
| 66 | -- |
- log = NULL) {
- |
-
| 67 | -- |
- #browser()- |
-
| 68 | -- |
- # Initialize logging if necessary- |
-
| 69 | -11x | -
- if (base::is.null(log)) {
- |
-
| 70 | -11x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 71 | -- |
- }- |
-
| 72 | -- |
- - |
-
| 73 | -11x | -
- log$debug(base::paste0('Selecting thresholds for term: ', Term, ' and context(s): ', base::paste0(Ctxt,collapse=','),
- |
-
| 74 | -11x | -
- ' for location: ', NameLoc, ' and date: ', Time))- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Handle dates- |
-
| 77 | -11x | -
- timeBgn <- Time- |
-
| 78 | -11x | -
- timeEnd <- timeBgn + base::as.difftime(1,units='days')- |
-
| 79 | -11x | -
- timeDoy <- lubridate::yday(timeBgn) # Day of year - only need one since data encompasses only 1 day- |
-
| 80 | -- |
- - |
-
| 81 | -- |
- # Filter thresholds only for this term, context, location (sensor, site, or REALM),- |
-
| 82 | -- |
- # date range (absolute and seasonal). Note that seasonal logic assumes start DOY < end DOY.- |
-
| 83 | -- |
- # Discard all null entries.- |
-
| 84 | -11x | -
- setFilt <- base::unlist(base::lapply(thsh,function(idxThsh){
- |
-
| 85 | -- |
- # This is one giant logical statement- |
-
| 86 | -70x | -
- !base::is.null(idxThsh$threshold_name) && # Non-null threshold name- |
-
| 87 | -70x | -
- idxThsh$term_name == Term && # Term- |
-
| 88 | -70x | -
- base::sum(Ctxt %in% base::unlist(idxThsh$context)) == base::length(Ctxt) && # Context- |
-
| 89 | -70x | -
- idxThsh$location_name %in% c(NameLoc,Site,'REALM') && # Location- |
-
| 90 | -70x | -
- (!base::is.null(idxThsh$start_date) && idxThsh$start_date <= timeEnd) && # Hard date range, part 1- |
-
| 91 | -70x | -
- (base::is.null(idxThsh$end_date) || idxThsh$end_date > timeBgn) && # Hard date range, part 2- |
-
| 92 | -70x | -
- (base::is.null(idxThsh$start_day_of_year) || idxThsh$start_day_of_year <= timeDoy) && # Seasonal date range, part 1- |
-
| 93 | -70x | -
- (base::is.null(idxThsh$end_day_of_year) || idxThsh$end_day_of_year >= timeDoy) && # Seasonal date range, part 2- |
-
| 94 | -70x | -
- (!base::is.null(idxThsh$number_value) || !base::is.null(idxThsh$string_value)) # Threshold needs to have a value!- |
-
| 95 | -- |
- }))- |
-
| 96 | -- |
- - |
-
| 97 | -- |
- # Error check- |
-
| 98 | -11x | -
- if(base::length(setFilt) == 0){
- |
-
| 99 | -1x | -
- log$error(base::paste0('No thresholds match term: ', Term, ' and context(s): ', base::paste0(Ctxt,collapse=','),
- |
-
| 100 | -1x | -
- ' for location: ', NameLoc, ' and date: ', timeBgn))- |
-
| 101 | -1x | -
- stop()- |
-
| 102 | -- |
- }- |
-
| 103 | -- |
- - |
-
| 104 | -- |
- # Make it pretty- |
-
| 105 | -10x | -
- thshFilt <- NEONprocIS.qaqc::def.read.thsh.qaqc.df(listThsh=thsh[setFilt])- |
-
| 106 | -- |
- - |
-
| 107 | -- |
- # Choose the correct value for each threshold. Note, this assumes that the absolute start/end dates and the- |
-
| 108 | -- |
- # seasonal start/end dates are on the daily resolution. No splitting days.- |
-
| 109 | -10x | -
- nameThsh <- base::unique(thshFilt$threshold_name)- |
-
| 110 | -10x | -
- setFiltUse <- base::numeric(0) # Initialize- |
-
| 111 | -10x | -
- log$debug(base::paste0('The following thresholds were found in the threshold file. Selections will be made for each: ',base::paste0(nameThsh,collapse=',')))
- |
-
| 112 | -10x | -
- for(idxNameThsh in nameThsh){
- |
-
| 113 | -- |
- # Create some general text for warning messages- |
-
| 114 | -12x | -
- txtGnl <- base::paste0('term = ',Term,', context =',base::paste0(Ctxt, collapse='|'),
- |
-
| 115 | -12x | -
- ', threshold=',idxNameThsh,', named location=',NameLoc, ', site=', Site,'. ')- |
-
| 116 | -- |
- - |
-
| 117 | -- |
- # The choice of constraint to use is determined by moving up the hierarchy from finer to- |
-
| 118 | -- |
- # coarser constraints until one applies. Thus, the finest applicable level of constraint- |
-
| 119 | -- |
- # is chosen. Threshold selection order is as follows:- |
-
| 120 | -- |
- # 1. Sensor-specific, seasonal- |
-
| 121 | -- |
- # 2. Sensor-spefific, annual- |
-
| 122 | -- |
- # 3. Site-specific, seasonal- |
-
| 123 | -- |
- # 4. Site-specific, annual- |
-
| 124 | -- |
- # 5. Realm, seasonal- |
-
| 125 | -- |
- # 6. Realm, annual- |
-
| 126 | -- |
- - |
-
| 127 | -- |
- # SENSOR & DOY-specific- |
-
| 128 | -12x | -
- setTest <- base::which(thshFilt$threshold_name==idxNameThsh & thshFilt$location_name==NameLoc &- |
-
| 129 | -12x | -
- !base::is.na(thshFilt$start_day_of_year) & !base::is.na(thshFilt$end_day_of_year))- |
-
| 130 | -12x | -
- numUse <- base::length(setTest)- |
-
| 131 | -12x | -
- if (numUse > 1){
- |
-
| 132 | -- |
- # There's a problem. There should never be more than one applicable threshold. The logic- |
-
| 133 | -- |
- # or the threshold information may be flawed.- |
-
| 134 | -2x | -
- log$warn(base::paste0('There are ',numUse,' valid sensor & DOY specific thresholds for ',
- |
-
| 135 | -2x | -
- txtGnl,'There is only supposed to be one. Going to take the first, ',- |
-
| 136 | -2x | -
- 'but you should investigate...'))- |
-
| 137 | -2x | -
- setTest <- setTest[1]- |
-
| 138 | -2x | -
- numUse <- base::length(setTest)- |
-
| 139 | -- |
- }- |
-
| 140 | -12x | -
- if(numUse == 1){
- |
-
| 141 | -- |
- # Got it! Record and move on- |
-
| 142 | -2x | -
- setFiltUse <- c(setFiltUse,setTest)- |
-
| 143 | -2x | -
- next()- |
-
| 144 | -- |
- }- |
-
| 145 | -- |
- - |
-
| 146 | -- |
- # SENSOR-specific- |
-
| 147 | -10x | -
- setTest <- base::which(thshFilt$threshold_name==idxNameThsh & thshFilt$location_name==NameLoc)- |
-
| 148 | -10x | -
- numUse <- base::length(setTest)- |
-
| 149 | -10x | -
- if (numUse > 1){
- |
-
| 150 | -- |
- # There's a problem. There should never be more than one applicable threshold. The logic- |
-
| 151 | -- |
- # or the threshold information may be flawed.- |
-
| 152 | -1x | -
- log$warn(base::paste0('There are ',numUse,' valid sensor-specific annual thresholds for ',
- |
-
| 153 | -1x | -
- txtGnl,'There is only supposed to be one. Going to take the first, ',- |
-
| 154 | -1x | -
- 'but you should investigate...'))- |
-
| 155 | -1x | -
- setTest <- setTest[1]- |
-
| 156 | -1x | -
- numUse <- base::length(setTest)- |
-
| 157 | -- |
- }- |
-
| 158 | -10x | -
- if(numUse == 1){
- |
-
| 159 | -- |
- # Got it! Record and move on- |
-
| 160 | -2x | -
- setFiltUse <- c(setFiltUse,setTest)- |
-
| 161 | -2x | -
- next()- |
-
| 162 | -- |
- }- |
-
| 163 | -- |
- - |
-
| 164 | -- |
- # SITE & DOY-specific- |
-
| 165 | -8x | -
- setTest <- base::which(thshFilt$threshold_name==idxNameThsh & thshFilt$location_name==Site &- |
-
| 166 | -8x | -
- !base::is.na(thshFilt$start_day_of_year) & !base::is.na(thshFilt$end_day_of_year))- |
-
| 167 | -8x | -
- numUse <- base::length(setTest)- |
-
| 168 | -8x | -
- if (numUse > 1){
- |
-
| 169 | -- |
- # There's a problem. There should never be more than one applicable threshold. The logic- |
-
| 170 | -- |
- # or the threshold information may be flawed.- |
-
| 171 | -1x | -
- log$warn(base::paste0('There are ',numUse,' valid site & season-specific thresholds for ',
- |
-
| 172 | -1x | -
- txtGnl,'There is only supposed to be one. Going to take the first, ',- |
-
| 173 | -1x | -
- 'but you should investigate...'))- |
-
| 174 | -1x | -
- setTest <- setTest[1]- |
-
| 175 | -1x | -
- numUse <- base::length(setTest)- |
-
| 176 | -- |
- }- |
-
| 177 | -8x | -
- if(numUse == 1){
- |
-
| 178 | -- |
- # Got it! Record and move on- |
-
| 179 | -1x | -
- setFiltUse <- c(setFiltUse,setTest)- |
-
| 180 | -1x | -
- next()- |
-
| 181 | -- |
- }- |
-
| 182 | -- |
- - |
-
| 183 | -- |
- # SITE-specific- |
-
| 184 | -7x | -
- setTest <- base::which(thshFilt$threshold_name==idxNameThsh & thshFilt$location_name==Site)- |
-
| 185 | -7x | -
- numUse <- base::length(setTest)- |
-
| 186 | -7x | -
- if (numUse > 1){
- |
-
| 187 | -- |
- # There's a problem. There should never be more than one applicable threshold. The logic- |
-
| 188 | -- |
- # or the threshold information may be flawed.- |
-
| 189 | -1x | -
- log$warn(base::paste0('There are ',numUse,' valid site-specific annual thresholds for ',
- |
-
| 190 | -1x | -
- txtGnl,'There is only supposed to be one. Going to take the first, ',- |
-
| 191 | -1x | -
- 'but you should investigate...'))- |
-
| 192 | -1x | -
- setTest <- setTest[1]- |
-
| 193 | -1x | -
- numUse <- base::length(setTest)- |
-
| 194 | -- |
- }- |
-
| 195 | -7x | -
- if(numUse == 1){
- |
-
| 196 | -- |
- # Got it! Record and move on- |
-
| 197 | -2x | -
- setFiltUse <- c(setFiltUse,setTest)- |
-
| 198 | -2x | -
- next()- |
-
| 199 | -- |
- }- |
-
| 200 | -- |
- - |
-
| 201 | -- |
- # REALM & DOY-specific- |
-
| 202 | -5x | -
- setTest <- base::which(thshFilt$threshold_name==idxNameThsh & thshFilt$location_name=='REALM' &- |
-
| 203 | -5x | -
- !base::is.na(thshFilt$start_day_of_year) & !base::is.na(thshFilt$end_day_of_year))- |
-
| 204 | -5x | -
- numUse <- base::length(setTest)- |
-
| 205 | -5x | -
- if (numUse > 1){
- |
-
| 206 | -- |
- # There's a problem. There should never be more than one applicable threshold. The logic- |
-
| 207 | -- |
- # or the threshold information may be flawed.- |
-
| 208 | -1x | -
- log$warn(base::paste0('There are ',numUse,' valid site & season-specific thresholds for ',
- |
-
| 209 | -1x | -
- txtGnl,'There is only supposed to be one. Going to take the first, ',- |
-
| 210 | -1x | -
- 'but you should investigate...'))- |
-
| 211 | -1x | -
- setTest <- setTest[1]- |
-
| 212 | -1x | -
- numUse <- base::length(setTest)- |
-
| 213 | -- |
- }- |
-
| 214 | -5x | -
- if(numUse == 1){
- |
-
| 215 | -- |
- # Got it! Record and move on- |
-
| 216 | -1x | -
- setFiltUse <- c(setFiltUse,setTest)- |
-
| 217 | -1x | -
- next()- |
-
| 218 | -- |
- }- |
-
| 219 | -- |
- - |
-
| 220 | -- |
- # REALM- |
-
| 221 | -4x | -
- setTest <- base::which(thshFilt$threshold_name==idxNameThsh & thshFilt$location_name=='REALM')- |
-
| 222 | -4x | -
- numUse <- base::length(setTest)- |
-
| 223 | -4x | -
- if (numUse > 1){
- |
-
| 224 | -- |
- # There's a problem. There should never be more than one applicable threshold. The logic- |
-
| 225 | -- |
- # or the threshold information may be flawed.- |
-
| 226 | -1x | -
- log$warn(base::paste0('There are ',numUse,' valid REALM-level annual thresholds for ',
- |
-
| 227 | -1x | -
- txtGnl,'There is only supposed to be one. Going to take the first, ',- |
-
| 228 | -1x | -
- 'but you should investigate...'))- |
-
| 229 | -1x | -
- setTest <- setTest[1]- |
-
| 230 | -1x | -
- numUse <- base::length(setTest)- |
-
| 231 | -- |
- }- |
-
| 232 | -4x | -
- if(numUse == 1){
- |
-
| 233 | -- |
- # Got it! Record and move on- |
-
| 234 | -4x | -
- setFiltUse <- c(setFiltUse,setTest)- |
-
| 235 | -4x | -
- next()- |
-
| 236 | -- |
- }- |
-
| 237 | -- |
- - |
-
| 238 | -- |
- # If we've reached the end without finding a threshold, error-out- |
-
| 239 | -! | -
- log$warn(base::paste0('No applicable thresholds found for ',txtGnl,'Downstream quality control may error.'))
- |
-
| 240 | -- |
- - |
-
| 241 | -- |
- } # End loop around unique threshold names- |
-
| 242 | -- |
- - |
-
| 243 | -- |
- # We have the set of thresholds for this term|context group, save it- |
-
| 244 | -10x | -
- setThshSlct <- base::which(setFilt)[setFiltUse]- |
-
| 245 | -- |
- - |
-
| 246 | -- |
- # Compare what we ended up with in our pretty table with the original json- |
-
| 247 | -10x | -
- cmpr <- base::all.equal(thshFilt[setFiltUse,],NEONprocIS.qaqc::def.read.thsh.qaqc.df(listThsh=thsh[setThshSlct]),check.attributes = FALSE)- |
-
| 248 | -10x | -
- if(!base::isTRUE(cmpr)){
- |
-
| 249 | -! | -
- log$fatal(base::paste0('Code error! Thresholds in filtered data frame do not match those from same index of JSON file. Indexing likely incorrect.'))
- |
-
| 250 | -! | -
- stop()- |
-
| 251 | -- |
- }- |
-
| 252 | -- | - - | -
| 253 | -- |
- # Remove any duplicates- |
-
| 254 | -10x | -
- setThshSlct <- base::unique(setThshSlct)- |
-
| 255 | -- |
- - |
-
| 256 | -- |
- # Are we returning the indices of the thresholds in the list, or the thresholds themselves?- |
-
| 257 | -10x | -
- if(RptThsh == TRUE){
- |
-
| 258 | -- |
- # Return the thresholds- |
-
| 259 | -8x | -
- rpt <- thsh[setThshSlct]- |
-
| 260 | -- |
- } else {
- |
-
| 261 | -- |
- # Return the indices- |
-
| 262 | -2x | -
- rpt <- setThshSlct- |
-
| 263 | -- |
- }- |
-
| 264 | -- |
- - |
-
| 265 | -10x | -
- return(rpt)- |
-
| 266 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read QAQC thresholds for NEON instrumented systems data products from JSON file to list- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read QA/QC threshold information from json file to list. Convert timestamps to POSIX.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param NameFile Character value. Filename (including relative or absolute path) of the- |
-
| 11 | -- |
- #' thresholds file. Must be json format.- |
-
| 12 | -- |
- #' @param strJson character string of data in JSON format (as produced by rjson::toJSON()). Note that- |
-
| 13 | -- |
- #' only one of NameFile, strJson, or thsh may be entered. If more than one are supplied, the first- |
-
| 14 | -- |
- #' valid input will be used.- |
-
| 15 | -- |
- #' @param listThsh A list of thresholds already read in (as produced by rjson::fromJSON() and extracted- |
-
| 16 | -- |
- #' from the main 'thresholds' list. Note that only one of NameFile, strJson, or listThsh may be entered.- |
-
| 17 | -- |
- #' If more than one are supplied, the first valid input will be used.- |
-
| 18 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 19 | -- |
- #' output in addition to standard R error messaging. Defaults to NULL, in which the logger will be- |
-
| 20 | -- |
- #' created and used within the function.- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @return A list of thresholds, with dates in fields start_date and end_date converted to POSIXct.- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @references- |
-
| 25 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 26 | -- | - - | -
| 27 | -- |
- #' @keywords Currently none- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @examples- |
-
| 30 | -- |
- #' # Not run- |
-
| 31 | -- |
- #' FileThsh <- "~/pfs/threshold/thresholds.json"- |
-
| 32 | -- |
- #' thshRaw <- rjson::fromJSON(file=FileThsh,simplify=TRUE),silent=FALSE)- |
-
| 33 | -- |
- #' thsh <- NEONprocIS.qaqc::def.read.thsh.qaqc.list(listThsh=thshRaw$thresholds) # This turns dates to POSIXct, which is required- |
-
| 34 | -- | - - | -
| 35 | -- | - - | -
| 36 | -- |
- #' @seealso \link[NEONprocIS.qaqc]{def.read.thsh.qaqc.df}
- |
-
| 37 | -- | - - | -
| 38 | -- |
- #' @export- |
-
| 39 | -- | - - | -
| 40 | -- |
- # changelog and author contributions / copyrights- |
-
| 41 | -- |
- # Cove Sturtevant (2020-03-14)- |
-
| 42 | -- |
- # original creation- |
-
| 43 | -- |
- ##############################################################################################- |
-
| 44 | -- |
- def.read.thsh.qaqc.list <- function(NameFile=NULL,- |
-
| 45 | -- |
- strJson=NULL,- |
-
| 46 | -- |
- listThsh=NULL,- |
-
| 47 | -- |
- log=NULL){
- |
-
| 48 | -- |
- - |
-
| 49 | -- |
- # Initialize logging if necessary- |
-
| 50 | -16x | -
- if (base::is.null(log)) {
- |
-
| 51 | -16x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 52 | -- |
- }- |
-
| 53 | -- |
- - |
-
| 54 | -- |
- - |
-
| 55 | -- |
- # Load in the raw json info- |
-
| 56 | -16x | -
- if(!is.null(NameFile)){
- |
-
| 57 | -13x | -
- thshRaw <- base::try(rjson::fromJSON(file=NameFile,simplify=TRUE),silent=FALSE)- |
-
| 58 | -13x | -
- if(base::class(thshRaw) == 'try-error'){
- |
-
| 59 | -- |
- # Generate error and stop execution- |
-
| 60 | -1x | -
- log$error(base::paste0('Threshold file ', NameFile, ' is unreadable or contains no data. Aborting...'))
- |
-
| 61 | -1x | -
- stop()- |
-
| 62 | -- |
- }- |
-
| 63 | -12x | -
- thshRaw <- thshRaw$thresholds- |
-
| 64 | -3x | -
- } else if(!base::is.null(strJson)){
- |
-
| 65 | -1x | -
- thshRaw <- rjson::fromJSON(json_str=strJson,simplify=TRUE)- |
-
| 66 | -1x | -
- thshRaw <- thshRaw$thresholds- |
-
| 67 | -- |
- } else {
- |
-
| 68 | -2x | -
- if(base::is.null(listThsh)){
- |
-
| 69 | -1x | -
- stop('One of NameFile, strJson, or listThsh must be supplied.')
- |
-
| 70 | -- |
- } else {
- |
-
| 71 | -1x | -
- thshRaw <- listThsh- |
-
| 72 | -- |
- # Account for the scenario in which the thresholds list has not been extracted- |
-
| 73 | -1x | -
- if(base::length(base::names(thshRaw) == 1) && base::names(thshRaw) == 'thresholds'){
- |
-
| 74 | -1x | -
- thshRaw <- thshRaw$thresholds- |
-
| 75 | -- |
- }- |
-
| 76 | -- |
- }- |
-
| 77 | -- |
- }- |
-
| 78 | -- |
- - |
-
| 79 | -- |
- # Turn dates to POSIXct- |
-
| 80 | -14x | -
- thsh <- base::lapply(thshRaw,function(idxThsh){
- |
-
| 81 | -79x | -
- if(!base::is.null(idxThsh$start_date)){
- |
-
| 82 | -79x | -
- idxThsh$start_date <- base::as.POSIXct(idxThsh$start_date,format='%Y-%m-%dT%H:%M:%OSZ',tz='GMT')- |
-
| 83 | -- |
- }- |
-
| 84 | -79x | -
- if(!base::is.null(idxThsh$end_date)){
- |
-
| 85 | -6x | -
- idxThsh$end_date <- base::as.POSIXct(idxThsh$end_date,format='%Y-%m-%dT%H:%M:%OSZ',tz='GMT')- |
-
| 86 | -- |
- }- |
-
| 87 | -79x | -
- return(idxThsh)- |
-
| 88 | -- |
- })- |
-
| 89 | -- |
- - |
-
| 90 | -14x | -
- return(thsh)- |
-
| 91 | -- |
- - |
-
| 92 | -- |
- }- |
-
| 93 | -- | - - | -
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Filter NEON instrumented systems QC JSON-formatted thresholds- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Filter QA/QC threshold information in JSON format (file or text) based- |
-
| 9 | -- |
- #' on matching field values.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @param NameFile Filename (including relative or absolute path). Must be json format.- |
-
| 12 | -- |
- #' @param strJson Json-formatted text. Only one of NameFile or strJson must be entered.- |
-
| 13 | -- |
- #' @param NameFileOut Filename (optional) for writing the filtered output (in json format). Default is- |
-
| 14 | -- |
- #' NULL, in which case the result is output to the environment- |
-
| 15 | -- |
- #' @param Term String vector of terms (field 'term_name' in the thresholds file/text) to search for.- |
-
| 16 | -- |
- #' Retrieves matches to any Term. Enter NULL (default) if not filtering based on term.- |
-
| 17 | -- |
- #' @param Ctxt # string vector of contexts (field 'context'). Enter NULL (default) if not filtered based- |
-
| 18 | -- |
- #' on context. NOTE: If either \code{Term} or \code{Ctxt} (not both) are populated, the filter will
- |
-
| 19 | -- |
- #' return matches to any entry in these inputs, treated individually. If both \code{Term} and \code{Ctxt}
- |
-
| 20 | -- |
- #' are populated, AND logic is applied, meaning that the \code{Term} must match one of the Term values
- |
-
| 21 | -- |
- #' and \code{Ctxt} must match ALL Context values.
- |
-
| 22 | -- | - - | -
| 23 | -- |
- #' @return If NameFileOut is entered, a filtered json file. Otherwise, a list output of the filtered- |
-
| 24 | -- |
- #' thresholds in json format- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @references- |
-
| 27 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 28 | -- | - - | -
| 29 | -- |
- #' @keywords Currently none- |
-
| 30 | -- | - - | -
| 31 | -- |
- #' @examples Currently none- |
-
| 32 | -- | - - | -
| 33 | -- |
- #' @seealso Currently none- |
-
| 34 | -- | - - | -
| 35 | -- |
- #' @export- |
-
| 36 | -- | - - | -
| 37 | -- |
- # changelog and author contributions / copyrights- |
-
| 38 | -- |
- # Cove Sturtevant (2019-05-16)- |
-
| 39 | -- |
- # original creation- |
-
| 40 | -- |
- ##############################################################################################- |
-
| 41 | -- |
- def.thsh.json.filt <- function(NameFile=NULL,- |
-
| 42 | -- |
- strJson=NULL,- |
-
| 43 | -- |
- NameFileOut=NULL,- |
-
| 44 | -- |
- Term=NULL,- |
-
| 45 | -- |
- Ctxt=NULL- |
-
| 46 | -- |
- ){
- |
-
| 47 | -- |
- - |
-
| 48 | -- |
- # Read in the thresholds json file- |
-
| 49 | -8x | -
- if(!is.null(NameFile)){
- |
-
| 50 | -7x | -
- thsh <- rjson::fromJSON(file=NameFile,simplify=TRUE)$thresholds- |
-
| 51 | -1x | -
- } else if (!is.null(strJson)){
- |
-
| 52 | -! | -
- thsh <- rjson::fromJSON(json_str=strJson,simplify=TRUE)$thresholds- |
-
| 53 | -- |
- } else {
- |
-
| 54 | -1x | -
- stop('Either NameFile or strJson must be supplied in the inputs (but not both).')
- |
-
| 55 | -- |
- }- |
-
| 56 | -7x | -
- numThsh <- base::length(thsh)- |
-
| 57 | -- |
- - |
-
| 58 | -- |
- # Find all matching records for selected term(s)- |
-
| 59 | -7x | -
- numCtxt <- base::length(Ctxt)- |
-
| 60 | -7x | -
- if (!is.null(Term) && !is.null(Ctxt)){
- |
-
| 61 | -12x | -
- setUse <- base::unlist(base::lapply(thsh,function(list){list$term_name %in% Term &&
- |
-
| 62 | -3x | -
- base::sum(Ctxt %in% base::unlist(list$context))==numCtxt}))- |
-
| 63 | -4x | -
- } else if (is.null(Term) && !is.null(Ctxt)){
- |
-
| 64 | -2x | -
- setUse <- base::unlist(base::lapply(thsh,function(list){base::sum(Ctxt %in% base::unlist(list$context))>0}))
- |
-
| 65 | -2x | -
- } else if (!is.null(Term) && is.null(Ctxt)){
- |
-
| 66 | -1x | -
- setUse <- base::unlist(base::lapply(thsh,function(list){list$term_name %in% Term}))
- |
-
| 67 | -- |
- } else {
- |
-
| 68 | -1x | -
- setUse <- base::rep(TRUE,numThsh)- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- - |
-
| 71 | -- |
- # Filter- |
-
| 72 | -7x | -
- rpt <- thsh[setUse]- |
-
| 73 | -- |
- - |
-
| 74 | -- |
- # Reinstate the 'thresholds' list- |
-
| 75 | -7x | -
- rpt <- base::list(thresholds=rpt)- |
-
| 76 | -- |
- - |
-
| 77 | -- |
- # Either return the output or write to file- |
-
| 78 | -7x | -
- if(base::is.null(NameFileOut)){
- |
-
| 79 | -1x | -
- return(rpt)- |
-
| 80 | -- |
- } else {
- |
-
| 81 | -6x | -
- base::write(rjson::toJSON(rpt,indent=3),file=NameFileOut)- |
-
| 82 | -- |
- }- |
-
| 83 | -- |
- - |
-
| 84 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Perform spike test using the median absolute deviation method- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Evaluate the spike test - whether an observation lies outside the median- |
-
| 9 | -- |
- #' plus/minus a multiple of the median absolute deviation computed over a surrounding window of- |
-
| 10 | -- |
- #' observations.- |
-
| 11 | -- | - - | -
| 12 | -- |
- #' @param data a numeric vector of observations- |
-
| 13 | -- |
- #' @param Meth Character value of either 'A' or 'B'. Method A evaluates the central point in- |
-
| 14 | -- |
- #' each window as the window slides along the timeseries. Method B evaluates all points within- |
-
| 15 | -- |
- #' each window as it slides along the timeseries by WndwStep each time, thus evaluating a point- |
-
| 16 | -- |
- #' multiple times. For this method, a point must be identified as a spike at least the fraction- |
-
| 17 | -- |
- #' of the time specified in WndwFracSpkMin to be flagged as a spike. Default is A.- |
-
| 18 | -- |
- #' @param ThshMad The threshold multiple of the median absolute deviation of the median (MAD) for- |
-
| 19 | -- |
- #' each window outside which a value must lie to be identified as a spike. Default is 7.- |
-
| 20 | -- |
- #' @param Wndw Integer window size for calculating MAD. Must be odd. If even, 1 will be added.- |
-
| 21 | -- |
- #' If adding 1 makes Wndw longer than the length of the data, 1 will be subtracted.- |
-
| 22 | -- |
- #' @param WndwStep Method B only. An integer value specifying the number of data points to slide- |
-
| 23 | -- |
- #' the window as it moves along the timeseries. Default is 1. Maximum is 1/2 the window size.- |
-
| 24 | -- |
- #' @param WndwFracSpkMin Method B only. Minimum threshold fraction of windows a point must fail- |
-
| 25 | -- |
- #' the spike test to be flagged as a spike.- |
-
| 26 | -- |
- #' @param NumGrp Either NULL or an integer value specifying the minimum number of consective spikes,- |
-
| 27 | -- |
- #' at and above which the points will be deemed plausible values and not flagged.- |
-
| 28 | -- |
- #' Defaults to NULL, which will result in no evaluation of consecutive spikes. Default is NULL.- |
-
| 29 | -- |
- #' @param NaFracMax Fraction between 0 and 1 specifying the maximum fraction of missing values- |
-
| 30 | -- |
- #' for which each window retains a sufficient sample size to determine the median absolute deviation.- |
-
| 31 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 32 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @return An integer vector the same length as data, with quality flag results of the spike test- |
-
| 35 | -- |
- #' (0 = pass, 1 = fail, -1 = cannot eval)- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @references- |
-
| 38 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 39 | -- |
- #' NEON.DOC.000783 - ATBD: Time Series Automatic Despiking for TIS Level 1 Data Products- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @keywords despike, plausibility, QA/QC, quality- |
-
| 42 | -- | - - | -
| 43 | -- |
- #' @examples- |
-
| 44 | -- |
- #' data <- c(1,2,3,4,3,2,1,2,3,4,50,3,2,1,2,3,4,3,2,1)- |
-
| 45 | -- |
- #' # Method A- |
-
| 46 | -- |
- #' qfSpk <- def.spk.mad(data=data,Meth='A',ThshMad=7,Wndw=5)- |
-
| 47 | -- |
- #'- |
-
| 48 | -- |
- #' # Method B- |
-
| 49 | -- |
- #' qfSpk <- def.spk.mad(data=data,Meth='B',ThshMad=7,Wndw=5,WndwStep=3,WndwFracSpkMin=0.5)- |
-
| 50 | -- | - - | -
| 51 | -- |
- #' @seealso \link[eddy4R.qaqc]{def.dspk.wndw}
- |
-
| 52 | -- | - - | -
| 53 | -- |
- #' @export- |
-
| 54 | -- | - - | -
| 55 | -- |
- # changelog and author contributions / copyrights- |
-
| 56 | -- |
- # Cove Sturtevant (2020-07-09)- |
-
| 57 | -- |
- # original creation- |
-
| 58 | -- |
- # Cove Sturtevant (2022-08-16)- |
-
| 59 | -- |
- # improve speed when dataset has a large proportion of missing values- |
-
| 60 | -- |
- ##############################################################################################- |
-
| 61 | -- |
- def.spk.mad <-- |
-
| 62 | -- |
- function(data,- |
-
| 63 | -- |
- Meth=c('A','B')[1],
- |
-
| 64 | -- |
- ThshMad=7,- |
-
| 65 | -- |
- Wndw,- |
-
| 66 | -- |
- WndwStep=1,- |
-
| 67 | -- |
- WndwFracSpkMin=0.1,- |
-
| 68 | -- |
- NumGrp=NULL,- |
-
| 69 | -- |
- NaFracMax=.1,- |
-
| 70 | -- |
- log = NULL) {
- |
-
| 71 | -- |
- # initialize logging if necessary- |
-
| 72 | -11x | -
- if (base::is.null(log)) {
- |
-
| 73 | -11x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 74 | -- |
- }- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Validate numeric data only- |
-
| 77 | -11x | -
- if (!NEONprocIS.base::def.validate.vector(vectIn = data,- |
-
| 78 | -11x | -
- TestNumc = TRUE,- |
-
| 79 | -11x | -
- log = log)) {
- |
-
| 80 | -1x | -
- stop()- |
-
| 81 | -- |
- }- |
-
| 82 | -- |
- - |
-
| 83 | -10x | -
- numData <- base::length(data)- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # Check input parameters- |
-
| 86 | -10x | -
- if(base::length(Meth) != 1 || !(Meth %in% c('A','B'))){
- |
-
| 87 | -1x | -
- log$fatal('Input argument Meth must be either "A" or "B"')
- |
-
| 88 | -1x | -
- stop()- |
-
| 89 | -- |
- }- |
-
| 90 | -9x | -
- if(base::length(ThshMad) != 1 || !base::is.numeric(ThshMad)){
- |
-
| 91 | -1x | -
- log$fatal('Input argument ThshMad must be a single numeric value')
- |
-
| 92 | -1x | -
- stop()- |
-
| 93 | -- |
- }- |
-
| 94 | -8x | -
- if(base::length(Wndw) != 1 || base::as.integer(Wndw) != Wndw || Wndw > numData){
- |
-
| 95 | -1x | -
- log$fatal('Input argument Wndw must be a single integer value')
- |
-
| 96 | -1x | -
- stop()- |
-
| 97 | -- |
- }- |
-
| 98 | -7x | -
- if(Wndw %% 2 == 0){
- |
-
| 99 | -5x | -
- if(Wndw != numData){
- |
-
| 100 | -1x | -
- Wndw <- Wndw + 1- |
-
| 101 | -1x | -
- log$info(base::paste0('Spike test window increased by 1 to ',Wndw, ' in order to make it odd'))
- |
-
| 102 | -- |
- } else {
- |
-
| 103 | -4x | -
- Wndw <- Wndw - 1- |
-
| 104 | -4x | -
- log$info(base::paste0('Spike test window decreased by 1 to ',Wndw, ' in order to make it odd'))
- |
-
| 105 | -- |
- }- |
-
| 106 | -- |
- }- |
-
| 107 | -7x | -
- if(base::length(WndwStep) != 1 || base::as.integer(WndwStep) != WndwStep || WndwStep < 1 || WndwStep > base::floor(Wndw/2)){
- |
-
| 108 | -1x | -
- log$fatal('Input argument WndwStep must be a single integer value >= 1 and <= Wndw/2')
- |
-
| 109 | -1x | -
- stop()- |
-
| 110 | -- |
- }- |
-
| 111 | -6x | -
- if(base::length(WndwFracSpkMin) != 1 || WndwFracSpkMin < 0 || WndwFracSpkMin > 1){
- |
-
| 112 | -1x | -
- log$fatal('Input argument WndwFracSpkMin must be a single value between 0 and 1')
- |
-
| 113 | -1x | -
- stop()- |
-
| 114 | -- |
- }- |
-
| 115 | -5x | -
- if(!is.null(NumGrp) && (base::length(NumGrp) != 1 || base::as.integer(NumGrp) != NumGrp || NumGrp < 1 || NumGrp > numData)){
- |
-
| 116 | -1x | -
- log$fatal('Input argument NumGrp must either be NULL or a single integer value >= 1 and <= length of the data')
- |
-
| 117 | -1x | -
- stop()- |
-
| 118 | -- |
- }- |
-
| 119 | -4x | -
- if(base::length(NaFracMax) != 1 || NaFracMax < 0 || NaFracMax > 1){
- |
-
| 120 | -! | -
- log$fatal('Input argument NaFracMax must be a single value between 0 and 1')
- |
-
| 121 | -! | -
- stop()- |
-
| 122 | -- |
- }- |
-
| 123 | -- |
- - |
-
| 124 | -- | - - | -
| 125 | -- |
- # Scale factor to use MAD as a consistent estimation of std- |
-
| 126 | -- |
- # equal to reciprocal of the quantile function at probability of 75%- |
-
| 127 | -4x | -
- CorStd <- 1.4826- |
-
| 128 | -- |
- - |
-
| 129 | -- |
- # Setup- |
-
| 130 | -4x | -
- dmmyVect <- rep(NA,numData)- |
-
| 131 | -4x | -
- numDataWndw<-dmmyVect- |
-
| 132 | -4x | -
- med <- dmmyVect- |
-
| 133 | -4x | -
- mad <- dmmyVect- |
-
| 134 | -4x | -
- qf <- rep(-1,numData)- |
-
| 135 | -- |
- - |
-
| 136 | -- |
- - |
-
| 137 | -- |
- # Let's skip everything if all the data are NA- |
-
| 138 | -4x | -
- if(base::sum(base::is.na(data))==numData){
- |
-
| 139 | -! | -
- return(as.integer(qf))- |
-
| 140 | -- |
- }- |
-
| 141 | -- |
- - |
-
| 142 | -- |
- # To use the running median and mad functions below, we must first handle NA values.- |
-
| 143 | -- |
- # Later iterations of the native R stats package handle NAs, but the 3.6.0 version does not.- |
-
| 144 | -- |
- # Uncomment the following and replace the med variable if running on 3.6.0- |
-
| 145 | -- |
- - |
-
| 146 | -- |
- # # Leaving the NAs in there causes some extra qf=-1 when the NA value is the first value in the window.- |
-
| 147 | -- |
- # # Let's replicate the "+Big_alternate" method of stats v3.6.2, which replaces NA values with alternating very large- |
-
| 148 | -- |
- # # numbers so that the median is unaffected.- |
-
| 149 | -- |
- # numBig <- .Machine$double.xmax/3- |
-
| 150 | -- |
- # setNa <- which(is.na(data))- |
-
| 151 | -- |
- # numBigAlt <- array(c(numBig,-numBig),length(setNa))- |
-
| 152 | -- |
- # dataPrepNa <- data- |
-
| 153 | -- |
- # dataPrepNa[setNa] <- numBigAlt- |
-
| 154 | -- |
- # # Compute the running median of the data- |
-
| 155 | -- |
- # med <- stats::runmed(x=dataPrepNa,k=Wndw,endrule='constant')- |
-
| 156 | -4x | -
- med <- stats::runmed(x=data,k=Wndw,endrule='constant',na.action="+Big_alternate") # window is centered- |
-
| 157 | -- | - - | -
| 158 | -- |
- # The caTools::runmad function is ultra fast when there are no missing values, but the- |
-
| 159 | -- |
- # performance degrades rapidly with increasing proportion of NA, especially when they are- |
-
| 160 | -- |
- # in large continuous chunks. If the proportion of NAs exceeds 15% we will use a different- |
-
| 161 | -- |
- # function. Performance of both methods scales ~linearly with data length. More could be done- |
-
| 162 | -- |
- # here to tailor which method is chosen according to gap distribution.- |
-
| 163 | -4x | -
- dataReal <- !base::is.na(data)- |
-
| 164 | -4x | -
- numDataReal <- base::sum(dataReal)- |
-
| 165 | -- |
- - |
-
| 166 | -4x | -
- if(numDataReal/numData >= 0.85){
- |
-
| 167 | -4x | -
- mad <- caTools::runmad(x=data,k=Wndw,constant=CorStd,endrule="NA",align='center',center=med)- |
-
| 168 | -- |
- } else {
- |
-
| 169 | -! | -
- mad <- data.table::frollapply(x=data,n=Wndw,FUN=stats::mad,na.rm=TRUE,constant=CorStd,fill=NA,align='center')- |
-
| 170 | -- |
- }- |
-
| 171 | -- | - - | -
| 172 | -4x | -
- numDataWndw[((Wndw-1)/2+1):(numData-(Wndw-1)/2)] <- RcppRoll::roll_sum(x=dataReal,n=Wndw,by=1,align='center',na.rm=TRUE)- |
-
| 173 | -- |
- - |
-
| 174 | -- |
- # Compute correction factor to reduce bias with low window size- |
-
| 175 | -4x | -
- corWndw <- numDataWndw/(numDataWndw-0.8)- |
-
| 176 | -4x | -
- if(base::min(numDataWndw,na.rm=TRUE) < 10){
- |
-
| 177 | -4x | -
- corWndw[numDataWndw == 9] <- 1.107- |
-
| 178 | -4x | -
- corWndw[numDataWndw == 8] <- 1.129- |
-
| 179 | -4x | -
- corWndw[numDataWndw == 7] <- 1.140- |
-
| 180 | -4x | -
- corWndw[numDataWndw == 6] <- 1.200- |
-
| 181 | -4x | -
- corWndw[numDataWndw == 5] <- 1.206- |
-
| 182 | -4x | -
- corWndw[numDataWndw == 4] <- 1.363- |
-
| 183 | -- |
- }- |
-
| 184 | -- |
- - |
-
| 185 | -- |
- # Adjust for window size, stardard deviation approx, and threshold factor- |
-
| 186 | -4x | -
- madAdj <- mad*corWndw*ThshMad- |
-
| 187 | -- |
- - |
-
| 188 | -- |
- # Determine the windows that have sufficient sample size to determine mad (indicated at index of central value)- |
-
| 189 | -4x | -
- setEval <- numDataWndw >= 4 & numDataWndw >= (1-NaFracMax)*Wndw # center indices with enough non-NA data points in the window- |
-
| 190 | -- |
- - |
-
| 191 | -- |
- # Evaluate spike test depending on chosen method- |
-
| 192 | -4x | -
- if (Meth == 'A'){
- |
-
| 193 | -- |
- - |
-
| 194 | -- |
- # Evaluate central point of each window for spike- |
-
| 195 | -3x | -
- setSpkFail <- setEval & (data < med-madAdj | data > med+madAdj)- |
-
| 196 | -3x | -
- setSpkPass <- setEval & !setSpkFail- |
-
| 197 | -- |
- - |
-
| 198 | -- |
- # Set the pass & fail flags (all others are -1)- |
-
| 199 | -3x | -
- qf[setSpkFail] <- 1- |
-
| 200 | -3x | -
- qf[setSpkPass] <- 0- |
-
| 201 | -- | - - | -
| 202 | -1x | -
- } else if (Meth == 'B'){
- |
-
| 203 | -- |
- - |
-
| 204 | -- |
- # Step through the windows at interval WndwStep, assessing all points in the window- |
-
| 205 | -1x | -
- numFail <- rep(0,numData)- |
-
| 206 | -1x | -
- numTest <- rep(0,numData)- |
-
| 207 | -1x | -
- for (idxBgn in seq(from=1,to=numData-Wndw+1,by=WndwStep)){
- |
-
| 208 | -- |
- - |
-
| 209 | -- |
- # Indices of the window- |
-
| 210 | -2x | -
- setWndw <- idxBgn:(idxBgn+Wndw-1)- |
-
| 211 | -2x | -
- idxMid <- idxBgn + (Wndw-1)/2- |
-
| 212 | -- |
- - |
-
| 213 | -- |
- # Evaluate the whole window, adding to the running count of times a data point has failed the spike test for each of the windows that pass across it- |
-
| 214 | -2x | -
- setSpkFailIdx <- setEval[idxMid] & abs(data[setWndw]-med[idxMid]) > madAdj[idxMid]- |
-
| 215 | -2x | -
- numFail[setWndw] <- numFail[setWndw] + setSpkFailIdx- |
-
| 216 | -2x | -
- numTest[setWndw] <- numTest[setWndw] + setEval[idxMid]- |
-
| 217 | -- |
- - |
-
| 218 | -- |
- }- |
-
| 219 | -- |
- - |
-
| 220 | -- |
- # Evaluate whether the counts of spike failures for each value surpass the threshold percentage- |
-
| 221 | -1x | -
- setSpkFail <- numFail/numTest >= WndwFracSpkMin # numTest = 0 results in NA- |
-
| 222 | -1x | -
- setSpkPass <- !setSpkFail- |
-
| 223 | -- |
- - |
-
| 224 | -1x | -
- qf[setSpkFail] <- 1 # NA values ignored (retained as -1)- |
-
| 225 | -1x | -
- qf[setSpkPass] <- 0 # NA values ignored (retained as -1)- |
-
| 226 | -- |
- - |
-
| 227 | -- |
- }- |
-
| 228 | -- |
- - |
-
| 229 | -- |
- # Set a fail to a pass if there are more than NumGrp consective fails (suggesting a real data pattern as opposed to spikes)- |
-
| 230 | -4x | -
- if(!is.null(NumGrp)){
- |
-
| 231 | -1x | -
- qfGrp <- utils::head(qf,-(NumGrp-1))- |
-
| 232 | -1x | -
- for(idx in 2:NumGrp){
- |
-
| 233 | -2x | -
- qfGrp <- qfGrp + qf[idx:(numData-NumGrp+idx)]- |
-
| 234 | -- |
- }- |
-
| 235 | -- |
- - |
-
| 236 | -1x | -
- setFix <- which(qfGrp == NumGrp)- |
-
| 237 | -1x | -
- for(idxFix in setFix){
- |
-
| 238 | -! | -
- qf[idxFix:(idxFix+NumGrp-1)] <- 0- |
-
| 239 | -- |
- }- |
-
| 240 | -- |
- - |
-
| 241 | -- |
- }- |
-
| 242 | -- |
- - |
-
| 243 | -4x | -
- return(as.integer(qf))- |
-
| 244 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Read QAQC thresholds for NEON instrumented systems data products from JSON file to data frame- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Read QA/QC threshold information from json file and convert to data frame.- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param NameFile Filename (including relative or absolute path). Must be json format.- |
-
| 11 | -- |
- #' @param strJson character string of data in JSON format (as produced by rjson::toJSON()). Note that- |
-
| 12 | -- |
- #' only one of NameFile, strJson, or thsh may be entered. If more than one are supplied, the first- |
-
| 13 | -- |
- #' valid input will be used.- |
-
| 14 | -- |
- #' @param listThsh A list of thresholds already read in (as produced by rjson::fromJSON()) and extracted- |
-
| 15 | -- |
- #' from the main 'thresholds' list. Note that only one of NameFile, strJson, or listThsh may be entered.- |
-
| 16 | -- |
- #' If more than one are supplied, the first valid input will be used.- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @return A data frame with all thresholds contained in the json file. Note that the context entries- |
-
| 19 | -- |
- #' for each threshold have been combined into a single pipe-delimited string.- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @references- |
-
| 22 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @keywords Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @examples Currently none- |
-
| 27 | -- | - - | -
| 28 | -- |
- #' @seealso \link[NEONprocIS.qaqc]{def.read.thsh.qaqc.list}
- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @export- |
-
| 31 | -- | - - | -
| 32 | -- |
- # changelog and author contributions / copyrights- |
-
| 33 | -- |
- # Cove Sturtevant (2019-05-16)- |
-
| 34 | -- |
- # original creation- |
-
| 35 | -- |
- # Cove Sturtevant (2024-07-11)- |
-
| 36 | -- |
- # fix bug turning NA values for dates into numeric- |
-
| 37 | -- |
- ##############################################################################################- |
-
| 38 | -- |
- def.read.thsh.qaqc.df <- function(NameFile=NULL,- |
-
| 39 | -- |
- strJson=NULL,- |
-
| 40 | -- |
- listThsh=NULL){
- |
-
| 41 | -- |
- - |
-
| 42 | -- |
- # Load in the raw json info- |
-
| 43 | -23x | -
- if(!is.null(NameFile)){
- |
-
| 44 | -2x | -
- listThsh <- rjson::fromJSON(file=NameFile,simplify=TRUE)- |
-
| 45 | -2x | -
- listThsh <- listThsh$thresholds- |
-
| 46 | -21x | -
- } else if(!base::is.null(strJson)){
- |
-
| 47 | -! | -
- listThsh <- rjson::fromJSON(json_str=strJson,simplify=TRUE)- |
-
| 48 | -! | -
- listThsh <- listThsh$thresholds- |
-
| 49 | -- |
- } else {
- |
-
| 50 | -21x | -
- if(base::is.null(listThsh)){
- |
-
| 51 | -1x | -
- stop('One of NameFile, strJson, or listThsh must be supplied.')
- |
-
| 52 | -- |
- }- |
-
| 53 | -- |
- }- |
-
| 54 | -- |
- - |
-
| 55 | -- |
- # Turn all the NULLs into NAs- |
-
| 56 | -22x | -
- listThsh <- base::lapply(listThsh,function(list){
- |
-
| 57 | -41x | -
- base::lapply(list,function(valu){
- |
-
| 58 | -451x | -
- if(base::is.null(valu) || base::length(valu)==0){
- |
-
| 59 | -159x | -
- return(NA)- |
-
| 60 | -- |
- } else {
- |
-
| 61 | -292x | -
- return(valu)- |
-
| 62 | -- |
- }- |
-
| 63 | -- |
- })- |
-
| 64 | -- |
- })- |
-
| 65 | -- |
- - |
-
| 66 | -- |
- # Turn context into pipe-separated string- |
-
| 67 | -22x | -
- listThsh <- base::lapply(listThsh,function(idxThsh){
- |
-
| 68 | -41x | -
- idxThsh$context <- base::paste0(idxThsh$context,collapse='|')- |
-
| 69 | -41x | -
- return(idxThsh)- |
-
| 70 | -- |
- })- |
-
| 71 | -- |
- - |
-
| 72 | -- |
- # Convert to data frame- |
-
| 73 | -22x | -
- listThsh <- base::lapply(listThsh,base::as.data.frame,stringsAsFactors=FALSE)- |
-
| 74 | -22x | -
- thsh <- base::do.call(base::rbind,listThsh)- |
-
| 75 | -- |
- - |
-
| 76 | -- |
- # Interpret the dates- |
-
| 77 | -22x | -
- if(!base::is.null(thsh) && base::nrow(thsh) > 0){
- |
-
| 78 | -- |
- # Start date- |
-
| 79 | -22x | -
- if (base::is.character(thsh$start_date)){
- |
-
| 80 | -2x | -
- thsh$start_date <- base::as.POSIXct(thsh$start_date,format='%Y-%m-%dT%H:%M:%OSZ',tz='GMT')- |
-
| 81 | -- |
- } else {
- |
-
| 82 | -20x | -
- thsh$start_date <- base::as.POSIXct(thsh$start_date,origin='1970-01-01',tz='GMT')- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- # End date- |
-
| 85 | -22x | -
- if (base::is.character(thsh$end_date)){
- |
-
| 86 | -2x | -
- thsh$end_date <- base::as.POSIXct(thsh$end_date,format='%Y-%m-%dT%H:%M:%OSZ',tz='GMT')- |
-
| 87 | -- |
- } else {
- |
-
| 88 | -20x | -
- thsh$end_date <- base::as.POSIXct(thsh$end_date,origin='1970-01-01',tz='GMT')- |
-
| 89 | -- |
- }- |
-
| 90 | -- |
- }- |
-
| 91 | -- |
- - |
-
| 92 | -22x | -
- return(thsh)- |
-
| 93 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compute "instantaneous" alpha, beta, and final quality flags- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Aggregate quality flags to produce alpha, beta, and final quality flags- |
-
| 9 | -- |
- #' for each L0' (instantaneous) record. The alpha flag is 1 when any of a set of selected- |
-
| 10 | -- |
- #' flags have a value of 1 (fail). The beta flag is 1 when any of a set of selected- |
-
| 11 | -- |
- #' flags cannot be evaluated (have a value of -1). If either the alpha flag or beta flag are raised,- |
-
| 12 | -- |
- #' the final quality is raised (value of 1).- |
-
| 13 | -- | - - | -
| 14 | -- |
- #' @param qf Data frame of named quality flags (values of -1,0,1)- |
-
| 15 | -- |
- #' @param Para (optional) A named list of:\cr- |
-
| 16 | -- |
- #' \code{qfAlph} A character vector of the names of quality flags in \code{qf} that are to be used
- |
-
| 17 | -- |
- #' to compute AlphaQF. If any of these flags have a value of 1 for a given record, AlphaQF will be- |
-
| 18 | -- |
- #' 1 for that record. May be NULL (or not in the list), in which case all flags found in \code{qf}
- |
-
| 19 | -- |
- #' will be used to compute AlphaQF.\cr- |
-
| 20 | -- |
- #' \code{qfBeta} A character vector of the names of quality flags in \code{qf} that are to be used
- |
-
| 21 | -- |
- #' to compute BetaQF. If any of these flags have a value of -1 for a given record, BetaQF will be- |
-
| 22 | -- |
- #' 1 for that record. May be NULL (or not in the list), in which case all flags found in \code{qf}
- |
-
| 23 | -- |
- #' will be used to compute BetaQF. Note that this action may be modified by the \code{qfBetaIgnr}
- |
-
| 24 | -- |
- #' list element below\cr- |
-
| 25 | -- |
- #' \code{qfBetaIgnr} A character vector of the names of quality flags in \code{qf} that, if any of
- |
-
| 26 | -- |
- #' their values equals 1 for a particular record, the betaQF flag for that record is automatically- |
-
| 27 | -- |
- #' set to 0 (ignores the values of all other flags). May be NULL, (or not in the list), in which- |
-
| 28 | -- |
- #' case this argument will be ignored.- |
-
| 29 | -- |
- #' Note that the entire Para argument defaults to NULL, which will follow the default actions- |
-
| 30 | -- |
- #' described above.- |
-
| 31 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 32 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 33 | -- | - - | -
| 34 | -- |
- #' @return A data frame of the alpha, beta, and final quality flags- |
-
| 35 | -- | - - | -
| 36 | -- |
- #' @references- |
-
| 37 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 38 | -- | - - | -
| 39 | -- |
- #' @keywords Currently none- |
-
| 40 | -- | - - | -
| 41 | -- |
- #' @examples- |
-
| 42 | -- |
- #' qf <- data.frame(QF1=c(1,-1,1,0,-1),QF2=c(-1,1,0,0,0),stringsAsFactors=FALSE)- |
-
| 43 | -- |
- #' Para <- list(qfAlph=c('QF1','QF2'),qfBeta=c('QF1','QF2'),qfBetaIgnr='QF2')
- |
-
| 44 | -- |
- #' def.qm.dp0p(qf=qf,Para=Para)- |
-
| 45 | -- | - - | -
| 46 | -- |
- #' @seealso Currently none- |
-
| 47 | -- | - - | -
| 48 | -- |
- #' @export- |
-
| 49 | -- | - - | -
| 50 | -- |
- # changelog and author contributions / copyrights- |
-
| 51 | -- |
- # Cove Sturtevant (2020-03-11)- |
-
| 52 | -- |
- # original creation- |
-
| 53 | -- |
- ##############################################################################################- |
-
| 54 | -- |
- def.qm.dp0p <- function(qf, Para = NULL, log = NULL) {
- |
-
| 55 | -- |
- # initialize logging if necessary- |
-
| 56 | -7x | -
- if (base::is.null(log)) {
- |
-
| 57 | -7x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 58 | -- |
- }- |
-
| 59 | -- |
- - |
-
| 60 | -- |
- # Validate the data frame- |
-
| 61 | -7x | -
- if (!NEONprocIS.base::def.validate.dataframe(dfIn = qf,- |
-
| 62 | -7x | -
- TestNumc = TRUE,- |
-
| 63 | -7x | -
- log = log)) {
- |
-
| 64 | -1x | -
- stop()- |
-
| 65 | -- |
- }- |
-
| 66 | -- |
- - |
-
| 67 | -- |
- # Grab the names of the quality flags- |
-
| 68 | -6x | -
- nameQfIn <- base::names(qf)- |
-
| 69 | -- |
- - |
-
| 70 | -- |
- # Initialize the output- |
-
| 71 | -6x | -
- qm <- qf[base::rep(nameQfIn[1], 3)]- |
-
| 72 | -6x | -
- base::names(qm) <- c('AlphaQF', 'BetaQF', 'FinalQF')
- |
-
| 73 | -6x | -
- qm[, ] <- 0 # intialize alpha, beta, and final QF to 0 (good)- |
-
| 74 | -- |
- - |
-
| 75 | -- |
- #---- Compute the alpha flag- |
-
| 76 | -6x | -
- if (base::is.null(Para$qfAlph)) {
- |
-
| 77 | -1x | -
- nameQf <- nameQfIn # All flags used to compute alpha QF- |
-
| 78 | -- |
- } else {
- |
-
| 79 | -5x | -
- nameQf <-- |
-
| 80 | -5x | -
- Para$qfAlph # Specific set of flags used to compute alpha QF- |
-
| 81 | -- |
- }- |
-
| 82 | -- |
- - |
-
| 83 | -- |
- # Error check - ensure that the contributing flags are included in the data- |
-
| 84 | -6x | -
- exstQf <- nameQf %in% nameQfIn- |
-
| 85 | -- |
- - |
-
| 86 | -6x | -
- if (!base::all(exstQf)) {
- |
-
| 87 | -2x | -
- log$warn(- |
-
| 88 | -2x | -
- base::paste0(- |
-
| 89 | -2x | -
- 'The flag(s): ',- |
-
| 90 | -2x | -
- base::paste0(nameQf[!exstQf], collapse = ','),- |
-
| 91 | -2x | -
- ' intended to contribute to the alpha flag were not found in the quality flags, and will not contribute to flag computation. Check input argument(s).'- |
-
| 92 | -- |
- )- |
-
| 93 | -- |
- )- |
-
| 94 | -2x | -
- nameQf <- nameQf[exstQf]- |
-
| 95 | -- |
- - |
-
| 96 | -- |
- }- |
-
| 97 | -- |
- - |
-
| 98 | -- |
- # Set the alpha flag to 1 when contributing flags = 1- |
-
| 99 | -6x | -
- setFail <- base::rowSums(qf[nameQf] == 1, na.rm = TRUE) > 0- |
-
| 100 | -6x | -
- qm[setFail, 'AlphaQF'] <- 1- |
-
| 101 | -6x | -
- log$debug(base::paste0(- |
-
| 102 | -6x | -
- base::sum(setFail),- |
-
| 103 | -6x | -
- ' value(s) in the alpha quality flag were set to 1'- |
-
| 104 | -- |
- ))- |
-
| 105 | -- |
- - |
-
| 106 | -- |
- - |
-
| 107 | -- |
- - |
-
| 108 | -- |
- #---- Compute the beta flag- |
-
| 109 | -- |
- - |
-
| 110 | -6x | -
- if (base::is.null(Para$qfBeta)) {
- |
-
| 111 | -1x | -
- nameQf <- nameQfIn # All flags used to compute beta QF- |
-
| 112 | -- |
- } else {
- |
-
| 113 | -5x | -
- nameQf <-- |
-
| 114 | -5x | -
- Para$qfBeta # Specific set of flags used to compute beta QF- |
-
| 115 | -- |
- }- |
-
| 116 | -- |
- - |
-
| 117 | -- |
- # Error check - ensure that the contributing flags are included in the data- |
-
| 118 | -6x | -
- exstQf <- nameQf %in% nameQfIn- |
-
| 119 | -- |
- - |
-
| 120 | -6x | -
- if (!base::all(exstQf)) {
- |
-
| 121 | -2x | -
- log$warn(- |
-
| 122 | -2x | -
- base::paste0(- |
-
| 123 | -2x | -
- 'The flag(s): ',- |
-
| 124 | -2x | -
- base::paste0(nameQf[!exstQf], collapse = ','),- |
-
| 125 | -2x | -
- ' intended to contribute to the beta flag were not found in the quality flags, and will not contribute to flag computation. Check input argument(s).'- |
-
| 126 | -- |
- )- |
-
| 127 | -- |
- )- |
-
| 128 | -2x | -
- nameQf <- nameQf[exstQf]- |
-
| 129 | -- |
- - |
-
| 130 | -- |
- }- |
-
| 131 | -- |
- - |
-
| 132 | -- |
- # Error check - ensure that the contributing flags are included in the data- |
-
| 133 | -6x | -
- exstQf <- Para$qfBetaIgnr %in% nameQfIn- |
-
| 134 | -- |
- - |
-
| 135 | -6x | -
- if (!base::all(exstQf)) {
- |
-
| 136 | -1x | -
- log$warn(- |
-
| 137 | -1x | -
- base::paste0(- |
-
| 138 | -1x | -
- 'The flag(s): ',- |
-
| 139 | -1x | -
- base::paste0(Para$qfBetaIgnr[!exstQf], collapse = ','),- |
-
| 140 | -1x | -
- ' indicated in qfBetaIgnr (intended to set the beta QF to 0 if their value is 1) were not found in the quality flags, and will not contribute to flag computation. Check input argument(s).'- |
-
| 141 | -- |
- )- |
-
| 142 | -- |
- )- |
-
| 143 | -1x | -
- Para$qfBetaIgnr <- Para$qfBetaIgnr[exstQf]- |
-
| 144 | -- |
- - |
-
| 145 | -- |
- }- |
-
| 146 | -- |
- # Set the beta flag to 1 when contributing flags = -1- |
-
| 147 | -6x | -
- setNa <-- |
-
| 148 | -6x | -
- base::rowSums(qf[nameQf] == -1, na.rm = TRUE) > 0 # At least one contributing flag = -1- |
-
| 149 | -6x | -
- setIgnr <-- |
-
| 150 | -6x | -
- base::rowSums(qf[Para$qfBetaIgnr] == 1, na.rm = TRUE) > 0 # One of the flags in qfBetaIgnr = 1- |
-
| 151 | -6x | -
- setFail <- setNa & !setIgnr # resultant set to fail beta QF- |
-
| 152 | -6x | -
- qm[setFail, 'BetaQF'] <- 1- |
-
| 153 | -6x | -
- log$debug(base::paste0(- |
-
| 154 | -6x | -
- base::sum(setFail),- |
-
| 155 | -6x | -
- ' value(s) in the beta quality flag were set to 1'- |
-
| 156 | -- |
- ))- |
-
| 157 | -- |
- - |
-
| 158 | -- |
- - |
-
| 159 | -- |
- #---- Compute the final quality flag- |
-
| 160 | -- |
- - |
-
| 161 | -6x | -
- setFail <-- |
-
| 162 | -6x | -
- qm$AlphaQF == 1 | qm$BetaQF == 1 # Either alpha or beta flag raised- |
-
| 163 | -6x | -
- qm[setFail, 'FinalQF'] <- 1- |
-
| 164 | -- |
- - |
-
| 165 | -6x | -
- return(qm)- |
-
| 166 | -- |
- - |
-
| 167 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Force a set of quality flags to a particular value based on the value of another flag- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Force a set of quality flags to a particular value based on the value of another flag- |
-
| 9 | -- | - - | -
| 10 | -- |
- #' @param qf Data frame of named quality flags (values of -1,0,1)- |
-
| 11 | -- |
- #' @param nameQfDrve Character string. The name of a single "driver" flag in \code{qf}.
- |
-
| 12 | -- |
- #' @param valuDrve Numeric. The value of the driver flag that will cause the forced flags in- |
-
| 13 | -- |
- #' \code{qfForc} to be set to \code{valuForc}
- |
-
| 14 | -- |
- #' @param nameQfForc Character vector. The names of flags in \code{qf} that are to be forced to \code{valuForc} if \code{qfDrve} equals \code{valuDrve}
- |
-
| 15 | -- |
- #' @param valuForc Numeric. The value that the flags in \code{qfForc} are to be set to when \code{qfDrve} equals \code{valuDrve}
- |
-
| 16 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 17 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 18 | -- | - - | -
| 19 | -- |
- #' @return The \code{qf} data frame, after forcing any applicable values.
- |
-
| 20 | -- | - - | -
| 21 | -- |
- #' @references- |
-
| 22 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 23 | -- | - - | -
| 24 | -- |
- #' @keywords Currently none- |
-
| 25 | -- | - - | -
| 26 | -- |
- #' @examples- |
-
| 27 | -- |
- #' qf <- data.frame(QF1=c(1,-1,1,0,-1),QF2=c(-1,1,0,0,0),stringsAsFactors=FALSE)- |
-
| 28 | -- |
- #' def.qf.forc(qf=qf,qfDrve='QF1',valuDrve=1,qfForc='QF2',valuForc=0)- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @seealso Currently none- |
-
| 31 | -- | - - | -
| 32 | -- |
- #' @export- |
-
| 33 | -- | - - | -
| 34 | -- |
- # changelog and author contributions / copyrights- |
-
| 35 | -- |
- # Cove Sturtevant (2020-03-11)- |
-
| 36 | -- |
- # original creation- |
-
| 37 | -- |
- ##############################################################################################- |
-
| 38 | -- |
- def.qf.forc <-- |
-
| 39 | -- |
- function(qf,- |
-
| 40 | -- |
- nameQfDrve,- |
-
| 41 | -- |
- valuDrve,- |
-
| 42 | -- |
- nameQfForc,- |
-
| 43 | -- |
- valuForc,- |
-
| 44 | -- |
- log = NULL) {
- |
-
| 45 | -- |
- # initialize logging if necessary- |
-
| 46 | -4x | -
- if (base::is.null(log)) {
- |
-
| 47 | -4x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 48 | -- |
- }- |
-
| 49 | -- |
- - |
-
| 50 | -- |
- # Validate the data frame- |
-
| 51 | -4x | -
- if (!NEONprocIS.base::def.validate.dataframe(dfIn = qf,- |
-
| 52 | -4x | -
- TestNumc = FALSE,- |
-
| 53 | -4x | -
- log = log)) {
- |
-
| 54 | -1x | -
- stop()- |
-
| 55 | -- |
- }- |
-
| 56 | -- |
- - |
-
| 57 | -- |
- # Grab the names of the quality flags- |
-
| 58 | -3x | -
- nameQfIn <- base::names(qf)- |
-
| 59 | -- |
- - |
-
| 60 | -- |
- # Error check - ensure that driver and forced flags are present in the data- |
-
| 61 | -3x | -
- exstQfDrve <- nameQfDrve %in% nameQfIn- |
-
| 62 | -3x | -
- exstQfForc <- nameQfForc %in% nameQfIn- |
-
| 63 | -- |
- - |
-
| 64 | -3x | -
- if (!exstQfDrve) {
- |
-
| 65 | -1x | -
- log$warn(- |
-
| 66 | -1x | -
- base::paste0(- |
-
| 67 | -1x | -
- 'Driver flag: ',- |
-
| 68 | -1x | -
- nameQfDrve,- |
-
| 69 | -1x | -
- ' not found in the flags files. No intended flag forcing involving this flag will occur. Check input argument(s).'- |
-
| 70 | -- |
- )- |
-
| 71 | -- |
- )- |
-
| 72 | -1x | -
- return(qf)- |
-
| 73 | -- |
- }- |
-
| 74 | -2x | -
- if (!base::all(exstQfForc)) {
- |
-
| 75 | -2x | -
- log$warn(- |
-
| 76 | -2x | -
- base::paste0(- |
-
| 77 | -2x | -
- 'Flags: ',- |
-
| 78 | -2x | -
- base::paste0(nameQfForc[!exstQfForc], collapse = ','),- |
-
| 79 | -2x | -
- ' were not found in the flags. Intended flag forcing involving these flags will not occur. Check input argument(s).'- |
-
| 80 | -- |
- )- |
-
| 81 | -- |
- )- |
-
| 82 | -2x | -
- nameQfForc <- nameQfForc[exstQfForc]- |
-
| 83 | -- |
- - |
-
| 84 | -2x | -
- if (base::length(nameQfForc) == 0) {
- |
-
| 85 | -1x | -
- return(qf)- |
-
| 86 | -- |
- }- |
-
| 87 | -- |
- }- |
-
| 88 | -- |
- - |
-
| 89 | -- |
- # Force the flags- |
-
| 90 | -1x | -
- setForc <- qf[[nameQfDrve]] == valuDrve- |
-
| 91 | -1x | -
- qf[setForc, nameQfForc] <- valuForc- |
-
| 92 | -1x | -
- log$debug(- |
-
| 93 | -1x | -
- base::paste0(- |
-
| 94 | -1x | -
- base::sum(setForc),- |
-
| 95 | -1x | -
- ' value(s) in flag(s): ',- |
-
| 96 | -1x | -
- base::paste0(nameQfForc, collapse = ','),- |
-
| 97 | -1x | -
- ' were set to ',- |
-
| 98 | -1x | -
- valuForc,- |
-
| 99 | -1x | -
- ' as a result of ',- |
-
| 100 | -1x | -
- nameQfDrve,- |
-
| 101 | -1x | -
- ' equaling ',- |
-
| 102 | -1x | -
- valuDrve- |
-
| 103 | -- |
- )- |
-
| 104 | -- |
- )- |
-
| 105 | -- |
- - |
-
| 106 | -1x | -
- return(qf)- |
-
| 107 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Compute alpha & beta quality metrics and final quality flag- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Aggregate alpha and beta summary flags into alpha & beta quality metrics- |
-
| 9 | -- |
- #' and the final quality flag.- |
-
| 10 | -- |
- #' The alpha flag is 1 when any of a set of selected- |
-
| 11 | -- |
- #' flags have a value of 1 (fail). The beta flag is 1 when any of a set of selected- |
-
| 12 | -- |
- #' flags cannot be evaluated (have a value of -1). If either the alpha flag or beta flag are raised,- |
-
| 13 | -- |
- #' the final quality is raised (value of 1).- |
-
| 14 | -- | - - | -
| 15 | -- |
- #' @param qfSmmy Numeric data frame of alpha and beta summary flags for each record, as produced by- |
-
| 16 | -- |
- #' NEONprocIS.qaqc::def.qm.dp0p, with named columns:\cr- |
-
| 17 | -- |
- #' \code{AlphaQF} 0 or 1 indicating (1) at least one of the contituent quality flags was raised high (1)\cr
- |
-
| 18 | -- |
- #' \code{BetaQF} 0 or 1 indicating (1) at least one of the contituent quality flags could not be evaluated (-1)\cr
- |
-
| 19 | -- |
- #' All records will be aggregated into a single set of summary metrics- |
-
| 20 | -- |
- #' @param Thsh Numeric value. The threshold fraction for the sum of the alpha and beta quality- |
-
| 21 | -- |
- #' metrics multiplied by the respective weights given in argument WghtAlphaBeta (below) at and above- |
-
| 22 | -- |
- #' which triggers the final quality flag. Default value = 0.2.- |
-
| 23 | -- |
- #' @param WghtAlphBeta 2-element numeric vector of weights for the alpha and beta quality metrics, respectively.- |
-
| 24 | -- |
- #' The alpha and beta quality metrics (in fraction form) are multiplied by these respective weights and summed.- |
-
| 25 | -- |
- #' If the resultant value is greater than the threshold value set in the Thsh argument, the final quality flag is- |
-
| 26 | -- |
- #' raised. Default is c(2,1).- |
-
| 27 | -- |
- #' @param log A logger object as produced by NEONprocIS.base::def.log.init to produce structured log- |
-
| 28 | -- |
- #' output. Defaults to NULL, in which the logger will be created and used within the function.- |
-
| 29 | -- | - - | -
| 30 | -- |
- #' @return A named numeric vector of:\cr- |
-
| 31 | -- |
- #' \code{AlphaQM} The alpha quality metric, indicating the percentage of input records in which the
- |
-
| 32 | -- |
- #' alpha quality flag was raised.\cr- |
-
| 33 | -- |
- #' \code{BetaQM} The beta quality metric, indicating the percentage of input records in which the
- |
-
| 34 | -- |
- #' beta quality flag was raised.\cr- |
-
| 35 | -- |
- #' \code{FinalQF} The final quality flag, computed via the description for input parameter \code{WghtAlphBeta}.
- |
-
| 36 | -- | - - | -
| 37 | -- |
- #' @references- |
-
| 38 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 39 | -- |
- #' NEON Algorithm Theoretical Basis Document: Quality Flags and Quality Metrics for TIS Data Products (NEON.DOC.001113) \cr- |
-
| 40 | -- |
- #' Smith, D.E., Metzger, S., and Taylor, J.R.: A transparent and transferable framework for tracking quality information in- |
-
| 41 | -- |
- #' large datasets. PLoS ONE, 9(11), e112249.doi:10.1371/journal.pone.0112249, 2014. \cr- |
-
| 42 | -- | - - | -
| 43 | -- |
- #' @keywords Currently none- |
-
| 44 | -- | - - | -
| 45 | -- |
- #' @examples- |
-
| 46 | -- |
- #' qfSmmy <- data.frame(AlphaQF=c(1,0,0,1,1),BetaQF=c(0,1,0,0,1),stringsAsFactors=FALSE)- |
-
| 47 | -- |
- #' def.qm.smmy(qfSmmy=qfSmmy)- |
-
| 48 | -- | - - | -
| 49 | -- |
- #' @seealso \code{\link[NEONprocIS.qaqc]{def.qm.dp0p}}
- |
-
| 50 | -- | - - | -
| 51 | -- |
- #' @export- |
-
| 52 | -- | - - | -
| 53 | -- |
- # changelog and author contributions / copyrights- |
-
| 54 | -- |
- # Cove Sturtevant (2021-12-07)- |
-
| 55 | -- |
- # original creation- |
-
| 56 | -- |
- ##############################################################################################- |
-
| 57 | -- |
- def.qm.smmy <- function(qfSmmy,- |
-
| 58 | -- |
- Thsh=0.2,- |
-
| 59 | -- |
- WghtAlphBeta=c(2,1),- |
-
| 60 | -- |
- log=NULL){
- |
-
| 61 | -- |
- - |
-
| 62 | -- |
- # initialize logging if necessary- |
-
| 63 | -5x | -
- if (base::is.null(log)) {
- |
-
| 64 | -5x | -
- log <- NEONprocIS.base::def.log.init()- |
-
| 65 | -- |
- }- |
-
| 66 | -- |
- - |
-
| 67 | -- |
- # Validate the inputs- |
-
| 68 | -5x | -
- chkInp <- NEONprocIS.base::def.validate.dataframe(dfIn=qfSmmy,- |
-
| 69 | -5x | -
- TestNumc=TRUE,- |
-
| 70 | -5x | -
- TestNameCol=c('AlphaQF','BetaQF'),
- |
-
| 71 | -5x | -
- log=log)- |
-
| 72 | -5x | -
- if(chkInp == FALSE){
- |
-
| 73 | -1x | -
- log$fatal('Input qfSmmy to function NEONprocIS.qaqc::def.qm.smmy must be a numeric data frame with minimum column inputs of AlphaQF and BetaQF.')
- |
-
| 74 | -1x | -
- stop()- |
-
| 75 | -- |
- }- |
-
| 76 | -4x | -
- if(!base::is.numeric(Thsh)){
- |
-
| 77 | -1x | -
- log$fatal('Input Thsh to function NEONprocIS.qaqc::def.qm.smmy must be numeric.')
- |
-
| 78 | -1x | -
- stop()- |
-
| 79 | -- |
- }- |
-
| 80 | -3x | -
- if(!base::is.numeric(WghtAlphBeta) && base::length(WghtAlphBeta) != 2){
- |
-
| 81 | -1x | -
- log$fatal('Input WghtAlphBeta to function NEONprocIS.qaqc::def.qm.smmy must be a numeric vector of length 2.')
- |
-
| 82 | -1x | -
- stop()- |
-
| 83 | -- |
- }- |
-
| 84 | -- |
- - |
-
| 85 | -- |
- # Compute alpha and beta quality metrics- |
-
| 86 | -2x | -
- numRow <- base::nrow(qfSmmy)- |
-
| 87 | -2x | -
- qmSmmy <- base::colSums(x=qfSmmy==1,na.rm=TRUE)/numRow*100- |
-
| 88 | -- |
- - |
-
| 89 | -- |
- # Compute final quality flag- |
-
| 90 | -2x | -
- if ((WghtAlphBeta[1]*qmSmmy['AlphaQF']/100) + (WghtAlphBeta[2]*qmSmmy['BetaQF']/100) >= Thsh) {
- |
-
| 91 | -1x | -
- qmSmmy['FinalQF'] <- 1- |
-
| 92 | -- |
- } else {
- |
-
| 93 | -1x | -
- qmSmmy['FinalQF'] <- 0- |
-
| 94 | -- |
- }- |
-
| 95 | -- | - - | -
| 96 | -2x | -
- qmSmmy <- qmSmmy[c('AlphaQF','BetaQF','FinalQF')]
- |
-
| 97 | -2x | -
- names(qmSmmy) <- c('AlphaQM','BetaQM','FinalQF')
- |
-
| 98 | -- |
- - |
-
| 99 | -2x | -
- return(qmSmmy)- |
-
| 100 | -- |
- }- |
-
| 1 | -- |
- ##############################################################################################- |
-
| 2 | -- |
- #' @title Dummy function to ensure eddy4R.base & eddy4R.qaqc are captured in the renv lockfile- |
-
| 3 | -- | - - | -
| 4 | -- |
- #' @author- |
-
| 5 | -- |
- #' Cove Sturtevant \email{csturtevant@battelleecology.org}
- |
-
| 6 | -- | - - | -
| 7 | -- |
- #' @description- |
-
| 8 | -- |
- #' Definition function. Load eddy4R.base and eddy4R.qaqc to ensure that these packages are- |
-
| 9 | -- |
- #' documented in the renv lockfile.- |
-
| 10 | -- | - - | -
| 11 | -- |
- #' @return eddy4R.base and eddy4R.qaqc are loaded- |
-
| 12 | -- | - - | -
| 13 | -- |
- #' @references- |
-
| 14 | -- |
- #' License: (example) GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007- |
-
| 15 | -- | - - | -
| 16 | -- |
- #' @keywords Currently none- |
-
| 17 | -- | - - | -
| 18 | -- |
- #' @examples Currently none- |
-
| 19 | -- | - - | -
| 20 | -- |
- #' @seealso Currently none- |
-
| 21 | -- | - - | -
| 22 | -- |
- #' @export- |
-
| 23 | -- | - - | -
| 24 | -- |
- # changelog and author contributions / copyrights- |
-
| 25 | -- |
- # Cove Sturtevant (2020-01-23)- |
-
| 26 | -- |
- # original creation- |
-
| 27 | -- |
- ##############################################################################################- |
-
| 28 | -- |
- def.load.eddy4R <- function(){
- |
-
| 29 | -- |
- - |
-
| 30 | -! | -
- library(eddy4R.base)- |
-
| 31 | -! | -
- library(eddy4R.qaqc)- |
-
| 32 | -- |
- - |
-
| 33 | -- |
- - |
-
| 34 | -- |
- }- |
-