#' Is this a valid LiPD
#'
#' @param L a lipd object
#' @param allow.ensemble Check for ensemble variables as well
#'
#' @return T/F
#' @export
<- (L,allow.ensemble = ){
good <-
#is list
(!(L)){
(glue::glue("{L$dataSetName}: LiPD object must be a list"))
()
}
#check root
rootRequired <- ("archiveType",
"dataSetName",
"datasetId",
"geo",
"lipdVersion")
rootRecommended <- ("paleoData",
"chronData",
"changelog",
"createdBy",
"pub")
(!("paleoData" %in% (L) | "chronData" %in% (L))){
(glue::glue("{L$dataSetName}: LiPD object must contain paleoData and/or chronData"))
good <-
}
(rr rootRequired){
(!(rr %in% (L))){
(glue::glue("{L$dataSetName}: LiPD object must contain {rr}"))
good <-
}
}
(rr rootRecommended){
(!(rr %in% (L))){
(glue::glue("LiPD object should ideally contain {rr}"))
}
}
# Check pub ---------------------------------------------------------------
(!validPub(L)){
(glue::glue("{L$dataSetName}: invalid pub section"))
good <-
}
# check funding -----------------------------------------------------------
# not used enough to worry about yet
# Check Geo ---------------------------------------------------------------
(!validGeo(L)){
(glue::glue("{L$dataSetName}: invalid geo section"))
good <-
}
# Check paleo measurement contents ---------------------------------------------------
(!validPaleo(L,allow.ensemble = allow.ensemble)){
(glue::glue("{L$dataSetName}: invalid paleoData section"))
good <-
}
# Check chron measurement contents ---------------------------------------------------
(!validChron(L,allow.ensemble = allow.ensemble)){
(glue::glue("{L$dataSetName}: invalid chronData section"))
good <-
}
#if it passes everything
(good){
()
}{
(L$dataSetName)
()
}
}
validPub <- (L){
(!"pub" %in% (L)){
(glue::glue("{L$dataSetName}: No publication metadata present"))
() #pubs not required
}
pub <- L$pub
(!(pub)){
(glue::glue("{L$dataSetName}: Publication must be a list"))
()
}
(!((pub))){
(glue::glue("{L$dataSetName}: Publication must be an unnamed list"))
()
}
((pub) < 1){
(glue::glue("{L$dataSetName}: Publication must have length >1"))
()
}
(i 1:(pub)){
p <- pub[i]]
(!(purrr::map_lgl(p,) | purrr::map_lgl(p,) | (p) == "author")){
(glue::glue("{L$dataSetName} pub{i}: All fields except author must be character or numeric fields"))
}
(((p) == "author")){
(!(p$author)){
(glue::glue("{L$dataSetName} pub{i}: author field should be a list"))
()
}
}
forbidden <- ("authors")
(f 1:(forbidden)){
(((p) == forbidden[f])){
(glue::glue("{L$dataSetName} pub{i}: {forbidden[f]} is a forbidden term"))
()
}
}
}
()
}
validGeo <- (L){
(!"geo" %in% (L)){
(glue::glue("{L$dataSetName}: No geo metadata present"))
()
}
geo <- L$geo
(!(geo)){
(glue::glue("{L$dataSetName}: Geo metadata must be a list"))
()
}
reqNames <- ("latitude","longitude")
(rn reqNames){
(!rn %in% (geo)){
(glue::glue("{rn} must be in geo object"))
()
}
}
mustNumeric <- ("latitude","longitude","elevation","sisalSiteId")
(mn mustNumeric){
(mn %in% (geo)){
(!(geo[mn]])){
(glue::glue("{mn} must be numeric"))
()
}
}
}
otherNames <- ((geo),mustNumeric)
#remove some common exceptions
probablyOk <- stringr::str_detect((otherNames),"depth") |
stringr::str_detect((otherNames),"volume") |
stringr::str_detect((otherNames),"area")
((probablyOk)){
otherNames <- otherNames-(probablyOk)]
}
(on otherNames){
(!(geo[on]])){
(glue::glue("{on} must be character"))
()
}
}
#check lat and long
(geo$latitude < -90 | geo$latitude > 90){
("geo$latitude is outside plausible boundaries")
}
(geo$longitude < -180 | geo$longitude > 360){
("geo$longitude is outside plausible boundaries")
}
()
}
validPaleo <- (L,allow.ensemble = ){
(!"paleoData" %in% (L)){
(glue::glue("{L$dataSetName}: No paleoData metadata present"))
() #pubs not required
}
paleo <- L$paleoData
(!(paleo)){
(glue::glue("{L$dataSetName}: Publication must be a list"))
()
}
(!((paleo))){
(glue::glue("{L$dataSetName}: paleoData must be an unnamed list"))
()
}
((paleo) < 1){
(glue::glue("{L$dataSetName}: paleoData must have length >1"))
()
}
tn <- purrr::map(paleo,) %>% ()
((!tn %in% ("measurementTable","ensembleTable","distributionTable","model"))){
(glue::glue("{L$dataSetName}:Invalid object names in paleoData"))
()
}
(p 1:(paleo)){
P <- paleo[p]]
#check measurementTable structure
(((P) == "measurementTable")){
(m 1:(P$measurementTable)){
MT <- P$measurementTable[m]]
#get the lists
il <- (purrr::map_lgl(MT,))
LS <- MT[il]
((LS) < 2){
(glue::glue("{L$dataSetName}: paleoData {p} measurementTable {m} has fewer than two variables"))
()
}
#check for valid variable
(!(purrr::map_lgl(LS,validVariable,allow.ensemble = allow.ensemble))){
(glue::glue("{L$dataSetName}: paleoData {p} measurementTable {m} has invalid variables"))
()
}
#check that all values are the same length
<- purrr::map_dbl(LS, variableLength)
(( < 1)){
(glue::glue("{L$dataSetName}: paleoData {p} measurementTable {m} variable values are missing"))
()
}
(!( == [1])){
(glue::glue("{L$dataSetName}: paleoData {p} measurementTable {m} variable values have different lengths"))
()
}
#check that age, depth and year are numeric
isNum <- purrr::map_lgl(LS, ~ ((.x$values)))
depthCol <- ((isNum) == "depth")
((depthCol) >= 1){
(!(isNum[depthCol])){
(glue::glue("{L$dataSetName}: paleoData {p} measurementTable {m} depth values are not numeric"))
()
}
}
ageCol <- ((isNum) == "age")
((ageCol) >= 1){
(!(isNum[ageCol])){
(glue::glue("{L$dataSetName}: paleoData {p} measurementTable {m} age values are not numeric"))
()
}
}
yearCol <- ((isNum) == "year")
((yearCol) >= 1){
(!(isNum[yearCol])){
(glue::glue("{L$dataSetName}: paleoData {p} measurementTable {m} year values are not numeric"))
()
}
}
}
}
}
()
}
validChron <- (L,allow.ensemble = ){
(!"chronData" %in% (L)){
(glue::glue("{L$dataSetName}: No chronData metadata present"))
() #pubs not required
}
chron <- L$chronData
(!(chron)){
(glue::glue("{L$dataSetName}: Publication must be a list"))
()
}
(!((chron))){
(glue::glue("{L$dataSetName}: chronData must be an unnamed list"))
()
}
((chron) < 1){
(glue::glue("{L$dataSetName}: chronData must have length >1"))
()
}
tn <- purrr::map(chron,) %>% ()
(((tn))){
(glue::glue("{L$dataSetName}:Invalid table names in chronData"))
()
}
((! tn %in% ("measurementTable","ensembleTable","distributionTable","model"))){
(glue::glue("{L$dataSetName}:Invalid table names in chronData"))
()
}
(p 1:(chron)){
P <- chron[p]]
#check measurementTable structure
(((P) == "measurementTable")){
(m 1:(P$measurementTable)){
MT <- P$measurementTable[m]]
#get the lists
il <- (purrr::map_lgl(MT,))
LS <- MT[il]
((LS) < 2){
(glue::glue("{L$dataSetName}: chronData {p} measurementTable {m} has fewer than two variables"))
()
}
#check for valid variable
(!(purrr::map_lgl(LS,validVariable,allow.ensemble = allow.ensemble))){
(glue::glue("{L$dataSetName}: chronData {p} measurementTable {m} has invalid variables"))
()
}
#check that all values are the same length
<- purrr::map_dbl(LS, ~ (.x$values))
(( < 1)){
(glue::glue("{L$dataSetName}: chronData {p} measurementTable {m} variable values are missing"))
()
}
(!( == [1])){
(glue::glue("{L$dataSetName}: chronData {p} measurementTable {m} variable values have different lengths"))
()
}
#check that age, depth and year are numeric
isNum <- purrr::map_lgl(LS, ~ ((.x$values)))
depthCol <- ((isNum) == "depth")
((depthCol) >= 1){
(!(isNum[depthCol])){
(glue::glue("{L$dataSetName}: chronData {p} measurementTable {m} depth values are not numeric"))
()
}
}
ageCol <- ((isNum) == "age")
((ageCol) >= 1){
(!(isNum[ageCol])){
(glue::glue("{L$dataSetName}: chronData {p} measurementTable {m} age values are not numeric"))
()
}
}
yearCol <- ((isNum) == "year")
((yearCol) >= 1){
(!(isNum[yearCol])){
(glue::glue("{L$dataSetName}: chronData {p} measurementTable {m} year values are not numeric"))
()
}
}
}
}
}
()
}
validVariable <- (V,allow.ensemble = ){
reqNames <- ("TSid","variableName","values","number")
(r reqNames){
(! r %in% (V)){
(glue::glue("Required variable {r} is missing"))
(glue::glue("TSid: {V$TSid}"))
(glue::glue("variableName: {V$variableName}"))
()
}
}
#check class
reqChar <- ("TSid","variableName")
(on reqChar){
(!(V[on]])){
(glue::glue("{on} must be character ({V$TSid} - {V$variableName})"))
()
}
}
#check vector
(!(V$values)){
#check for 1 column matrix
((V$values)){
((V$values) == 1){
()
} ((V$values) > 1){
(allow.ensemble){
()
}{
(glue::glue("variable values must be a one column vector (allow.ensemble = FALSE) and ({V$TSid} - {V$variableName}) is a multicolumn"))
()
}
}
}
(glue::glue("variable values must be a vector ({V$TSid} - {V$variableName})"))
()
}
()
}
validMultiLipd <- (){
(purrr::map_lgl(,))
}
variableLength <- (VL){
((VL$values)){
((VL$values))
}{
((VL$values))
}
}
