diff --git a/.DS_Store b/.DS_Store index 1a2f69f..c2a7914 100644 Binary files a/.DS_Store and b/.DS_Store differ diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 0b26021..a7276e8 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -19,8 +19,10 @@ jobs: group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write steps: - - uses: actions/checkout@v2 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-pandoc@v2 @@ -39,7 +41,7 @@ jobs: - name: Deploy to GitHub pages 🚀 if: github.event_name != 'pull_request' - uses: JamesIves/github-pages-deploy-action@4.1.4 + uses: JamesIves/github-pages-deploy-action@v4.5.0 with: clean: false branch: gh-pages diff --git a/DESCRIPTION b/DESCRIPTION index 73103db..e9e084b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -18,7 +18,7 @@ Maintainer: Nicholas McKay Description: Functions to open, modify, analyze, and save LiPD data. Depends: R (>= 3.5.0) License: MIT + file LICENSE -RoxygenNote: 7.2.1 +RoxygenNote: 7.3.1 URL: www.lipd.net Encoding: UTF-8 Imports: diff --git a/NAMESPACE b/NAMESPACE index 2a096c4..460f589 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method(cbind,"NA") S3method(print,lipd) S3method(print,lipd_ts) S3method(print,lipd_ts_tibble) @@ -82,8 +83,6 @@ export(is.multiLipd) export(is.url) export(isDirectory) export(isNullOb) -export(isValidAll) -export(isValidValue) export(lipdSummary) export(lipdTSSummary) export(lipd_read) @@ -115,7 +114,6 @@ export(rm_empty_fields) export(rm_existing_tables) export(splitInterpretationByScope) export(standardizeQCsheetValues) -export(standardizeValue) export(stripExtension) export(swapGeoCoordinates) export(tabulateTs) @@ -126,7 +124,6 @@ export(unindex_geo) export(untidyTs) export(unzipper) export(updateChangelog) -export(updateMetaDataFromStandardTables) export(updateQueryTable) export(update_lipd_v1_1) export(update_lipd_v1_2) diff --git a/R/cbind_NA.R b/R/cbind_NA.R index c551b2b..2a7ebc3 100644 --- a/R/cbind_NA.R +++ b/R/cbind_NA.R @@ -1,3 +1,10 @@ +#' handle NAs in cbind +#' +#' @param ... whatever you're binding +#' @param fill unused parameter +#' +#' @return bound columns +#' @export cbind.NA <- function (..., fill = NA) { DFx <- list(...) @@ -10,7 +17,7 @@ cbind.NA <- function (..., fill = NA) DFx[[i]] <- data.frame(rep(NA, 1)) } } - + vertLen <- function(dfIn){ if(is.null(dim(dfIn))){ vertical <- length(dfIn) @@ -19,7 +26,7 @@ cbind.NA <- function (..., fill = NA) } return(vertical) } - + lengthsDF <- as.numeric(lapply(DFx, vertLen)) maxLen <- max(lengthsDF) newDF <- rep(NA, maxLen) diff --git a/R/standardization.R b/R/standardization.R deleted file mode 100644 index e526c34..0000000 --- a/R/standardization.R +++ /dev/null @@ -1,745 +0,0 @@ -#' Get Standard tables -#' -getStandardTables <- function(){ - if(exists("standardTables",envir = lipdEnv)){ - standardTables <- get("standardTables",envir = lipdEnv) - }else{ - standardTables <- updateStandardTables() - } - return(standardTables) -} - -#' grab metaData for given key from standard tables -#' -#' @param lipdTS a lipd TS object -#' @param key the key to check -#' -#' @return list -#' @export -updateMetaDataFromStandardTables <- function(lipdTS, key){ - - standardTables <- getStandardTables() - - TSorig <- lipdTS - - - #Check for appropriate key - if (!key %in% names(standardTables)){ - stop(paste("key must be one of: ", paste(names(standardTables),collapse = ", "))) - } - - #Which metadata needs updated for the given key? - if (key == "paleoData_variableName"){ - meta_keys <- c("paleoData_isAssemblage", "paleoData_datum", "paleoData_summaryStatistic", "paleoData_measurementMaterial", - "paleoData_inferredMaterial", "paleoData_method", "paleoData_isPrimary") - }else if (key == "paleoData_proxy"){ - meta_keys <- c("paleoData_proxyGeneral", "paleoData_measurementMaterial") - }else if (key == "paleoData_units"){ - meta_keys <- c("paleoData_datum") - }else{ - returns <- list("TS" = lipdTS, "ChangesDF" = NULL) - - return(returns) - } - - #Check that the metadata keys and primary key exist, if not, add them - if(!sum(unlist(lapply(lipdTS, function(x) all(meta_keys %in% names(x))))) == length(lipdTS)){ - #add keys where necessary - allKeys <- c(meta_keys, key) - for (i in 1:length(lipdTS)){ - needAdded <- allKeys[!allKeys %in% names(lipdTS[[i]])] - for (j in needAdded){ - lipdTS[[i]][eval(j)] <- NA - } - } - } - - #update metadata - #move through each TS, for each metadata field - newValues <- data.frame(matrix(nrow = length(lipdTS), ncol = length(meta_keys)+1)) - names(newValues) <- c("rowNum", meta_keys) - for (i in 1:length(lipdTS)){ - #find TS synonym in spreadsheet - synonymLoc <- which(unlist(unname(lipdTS[[i]][eval(key)])) == standardTables[[eval(key)]]['synonym']) - newValues[i,1] <- i - for (j in 1:length(meta_keys)){ - #If the field is blank, check the spreadsheet for metadata based on the synonym in the TS - if (is_blank(lipdTS[[i]][eval(meta_keys[j])])){ - newVal <- unlist(standardTables[[eval(key)]][synonymLoc,eval(meta_keys[j])]) - if (length(newVal)==0){ - newVal <- NA - } - if (is.null(newVal)){ - newVal <- NA - } - newValues[i,(j+1)] <- newVal - lipdTS[[i]][eval(meta_keys[j])] <- newVal - } - } - } - - # getTsVar <- function(TS1, keyNow, TSnum){ - # tryCatch( - # { - # pullTsVariable(TS1[[TSnum]], keyNow) - # }, - # error=function(cond){ - # return(NA) - # }, - # warning=function(cond){ - # message(cond) - # } - # ) - # } - # - # #compare original TS to new TS - # compDF <- data.frame(matrix(nrow = length(lipdTS), ncol = length(meta_keys))) - # names(compDF) <- meta_keys - # for (i in 1:length(lipdTS)){ - # for (j in 1:length(meta_keys)){ - # currentKey <- meta_keys[j] - # origVal <- getTsVar(TSorig, currentKey, i) - # newVal <- getTsVar(lipdTS, currentKey, i) - # if (is.null(newVal) | is.null(origVal) | length(newVal)==0 | length(origVal)==0){ - # compDF[i,eval(currentKey)] <- NA - # }else{ - # compDF[i,eval(currentKey)] <- newVal == origVal - # } - # - # } - # # if (length(comps)==0){ - # # compDF[i,] <- rep(NA, length(meta_keys)) - # # }else{ - # # if (length(comps) != ncol(compDF)){ - # # stop("Problem at: ", i, " in compDF due to comps = ", paste(comps, collapse = ", ")) - # # } - # # compDF[i,] <- comps - # # } - # } - - returns <- list("TS" = lipdTS, "ChangesDF" = newValues) - - return(returns) - -} - - - -#Checking function -#check the validity in the appropriate spreadsheet -#' Check all values of a given key for validity in appropriate spreadsheet -#' -#' @param lipdTS a lipdTS object -#' @param key key name -#' @param keyGeneral generalized key name -#' -#' @return invalidDF -#' -checkKey <- function(lipdTS, key, keyGeneral){ - TSvalsO <- pullTsVariable(lipdTS, key,strict.search = TRUE) - - #TSvals <- tolower(TSvalsO) - numVals <- length(TSvalsO) - -#standardVals0 <- unique(standardTables[[eval(keyGeneral)]][["lipdName"]]) -standardVals <- unique(standardTables[[eval(keyGeneral)]][["lipdName"]]) - -# validCheck0 <- TSvalsO %in% standardVals0 | -# is.na(TSvals) | -# is.null(TSvals) - -validCheck <- TSvalsO %in% standardVals | - is.na(TSvalsO) | - is.null(TSvalsO) - -#capDiff <- which(validCheck != validCheck0) - - - -# -# validCheck <- unlist(lapply(tolower(TSvals), function(x) x %in% -# tolower(unname(unlist(standardTables[[eval(keyGeneral)]]["lipdName"]))))) | -# unlist(lapply(tolower(TSvals), function(x) is.na(x))) | -# unlist(lapply(tolower(TSvals), function(x) is.null(x))) - - - numInvalid <- sum(!validCheck) - invalidI <- which(!validCheck) - message("Found ", numInvalid, " invalid keys from ", length(unlist(validCheck)), " total entries for ", key, "\n") - - invalidDF <- as.data.frame(matrix(nrow = numInvalid, ncol = 5)) - countA <- 0 - - TSid <- pullTsVariable(lipdTS,"paleoData_TSid",strict.search = TRUE) - datasetId <- pullTsVariable(lipdTS,"datasetId",strict.search = TRUE) - dataSetName <- pullTsVariable(lipdTS,"dataSetName",strict.search = TRUE) - - - invalidDF <- data.frame(rowNum = invalidI, - TSid = TSid[invalidI], - dataSetName = dataSetName[invalidI], - datasetId = datasetId[invalidI], - keyTBD = TSvalsO[invalidI]) - - - names(invalidDF)[5] <- eval(key) - - return(invalidDF) -} - - - -#' make sure all terms under a controlled key are valid -#' -#' @param lipdTS a lipd-ts object -#' @param key the key that you want to check -#' -#' @return invalid keys df -#' @export - -isValidValue <- function(lipdTS, key = NA){ - - standardTables <- getStandardTables() - - if (!methods::is(lipdTS, "lipd-ts")){ - lipdTs <- as.lipdTs(lipdTS) - } - - - if (!key %in% names(standardTables)){ - stop(paste("key must be one of: ", paste(names(standardTables),collapse = ", "))) - } - - - #interpretation keys (seasonality and variable) - interpretation <- FALSE - if (grepl("interpretation", key)){ - interpretation <- TRUE - } - - #look for all keys that include "interpretation" and c("seasonaility" or "variable") - if (interpretation){ - - keyID <- sub(".*_", "", key) - possibleKeys <- lapply(1:100, function(x) paste0("interpretation", x, "_", keyID)) - keysAll <- lapply(lipdTS, function(x) names(x)[names(x) %in% possibleKeys]) - - - keyGeneral <- gsub('[0-9]+', '', key) - - - #how many of these keys exist for each record, save the max number - #numKeysMax <- max(unlist(lapply(keysAll, function(x) length(x)))) - - uniqueKeys <- unique(unlist(keysAll)) - - #run check for each unique, eg. interpretation1_seasonality - returns <- lapply(uniqueKeys, function(x) checkKey(lipdTS, x, keyGeneral)) - }else{ - - returns <- checkKey(lipdTS, key, key) - } - - # if (!verbose){ - # returns <- NULL - # } - - invisible(returns) -} - - - - -#' standardize terms automatically based on known synonyms -#' -#' @param lipdTS a lipd TS object -#' @param key the key to check -#' -#' @return updated TS -#' @export - -standardizeValue <- function(lipdTS, key = NA){ - - - standardTables <- getStandardTables() - - if (!methods::is(lipdTS, "lipd-ts")){ - lipdTs <- as.lipdTs(lipdTS) - } - - invalidDF <- isValidValue(lipdTS, key) - - - #interpretation keys (seasonality and variable) - interpretation <- FALSE - if (grepl("interpretation", key)){ - interpretation <- TRUE - uniqueKeys <- lapply(invalidDF, function(x) names(x)[5]) - message("Standardizing ", length(invalidDF), " unique keys:\n", paste(uniqueKeys, collapse = "\n")) - } - - #Find and replace synonyms - replaceSynonyms <- function(TS=lipdTS, key=NA, invalidDF=NA, interpretation = interpretation){ - noSynonym <- data.frame("TSid" = NA, "key" = NA) - - if (nrow(invalidDF) > 0){ - #add a "keyGeneral" variable for interps - if(interpretation){ - keyGeneral <- gsub('[0-9]+', '', key) - }else{ - keyGeneral <- key - } - #find synonyms based on "synonym" and "pastName" - possibleSynonyms <- unique(c(tolower(unname(unlist(standardTables[[eval(keyGeneral)]]["synonym"]))), - tolower(unname(unlist(standardTables[[eval(keyGeneral)]]["paleoData_pastName"]))))) - possibleSynonyms <- possibleSynonyms[!is.na(possibleSynonyms)] - - #Are the current values in the TS for this key valid (are they known lipdNames) - - validCheck2 <- lapply(lipdTS, function(x) tolower(unname(unlist(x[eval(key)]))) %in% - tolower(unname(unlist(standardTables[[eval(keyGeneral)]]["lipdName"])))) - - #Build a data frame to show replacement on known synonyms with valid lipdNames - synonymDF <- as.data.frame(matrix(nrow = sum(!unlist(validCheck2)), ncol = 5)) - names(synonymDF) <- c("rowNum", "dataSetName", "dataSetId", as.character(key), "New") - countEm <- 0 - for (i in 1:nrow(invalidDF)){ - - TSrowNum <- invalidDF$rowNum[[i]] - - synonymLoc <- which(tolower(invalidDF[i,5]) == possibleSynonyms) - - if(length(synonymLoc) == 0){ - nosynonym1 <- data.frame("TSid" = lipdTS[[TSrowNum]]$paleoData_TSid, - "key" = key) - noSynonym <- rbind.data.frame(noSynonym, nosynonym1) - }else{ - countEm <- countEm + 1 - #find the known synonym - synonym <- possibleSynonyms[synonymLoc] - - #locate the corresponding lipdName - synonymTableLoc <- which(synonym == tolower(unname(unlist(standardTables[[eval(keyGeneral)]]["synonym"])))) - lipdName <- unname(unlist(standardTables[[eval(keyGeneral)]]["lipdName"]))[synonymTableLoc[1]] - - synonymDF[countEm,1] <- TSrowNum - synonymDF[countEm,2] <- lipdTS[[as.numeric(TSrowNum)]]$dataSetName - synonymDF[countEm,3] <- lipdTS[[as.numeric(TSrowNum)]]$datasetId - synonymDF[countEm,4] <- invalidDF[i,5] - synonymDF[countEm,5] <- lipdName - } - - #print(invalidDF[i,5]) - #newRow <- c(TSrowNum, lipdTS[[as.numeric(TSrowNum)]]$dataSetName, lipdTS[[as.numeric(TSrowNum)]]$datasetId, invalidDF[i,5], lipdName) - - # if (length(newRow) != 5){ - # stop("Problem with TS ", newRow, " for ", key) - # } - - - - #lipdTS[[as.numeric(TSrowNum)]][eval(key)] <<- lipdName - - } - - synonymDForig <- synonymDF - print(tibble::tibble(synonymDF)) - - # userResp <- askYesNo(msg = "Replace all?" , default = TRUE) - # - # # if(userResp){ - # for (i in 1:nrow(synonymDF)){ - # lipdTS[[as.numeric(synonymDF$rowNum[i])]][eval(key)] <<- synonymDF[synonymDF$rowNum[i],5] - # } - #} - - if(interpretation){ - keyGeneral <- gsub('[0-9]+', '', key) - }else{ - keyGeneral <- key - } - - - # message("Rerunning check for invalid keys in: ", key) - # if (key %in% lapply(isValidValue(lipdTS, keyGeneral), function(x) names(x)[5])){ - # invalidDFnew <- checkKey(lipdTS, key) - # print(tibble::tibble(invalidDFnew)) - # } - - if (nrow(noSynonym) > 1){ - noSynonym <- noSynonym[-1,] - } - - - - returns1 <- list("synonymDF" = synonymDForig) - returns2 <- list("noSynonym" = noSynonym) - returns <- list(returns1=returns1, returns2=returns2) - }else{ - returns <- NULL - } - - - return(returns) - } - - returns <- list() - if (interpretation){ - for (i in 1:length(invalidDF)){ - if (nrow(invalidDF[[i]]>0)){ - returns[[i]] <- replaceSynonyms(lipdTS, key=names(invalidDF[[i]])[5], invalidDF[[i]], interpretation) - } - - } - #returns <- lapply(invalidDF, function(x) replaceSynonyms(lipdTS, key=names(x)[5], x, interpretation)) - }else{ - returns <- replaceSynonyms(lipdTS, key, invalidDF, interpretation) - } - - deleteTheseTS <- c() - - - if (!sum(grepl("returns1", names(returns)))>0){ - df0 <- list() - df10 <- list() - for (i in 1:length(returns)){ - df1 <- returns[[i]]$returns1$synonymDF - df0[[i]] <- df1 - df2 <- returns[[i]]$returns2$noSynonym - df10[[i]] <- df2 - if (length(df1) > 0){ - if(!is.null(nrow(df1))){ - for (j in 1:nrow(df1)){ - rowNum <- df1$rowNum[j] - newVal <- df1$New[j] - if(!is.na(rowNum) & length(rowNum) > 0){ - if (grepl("delete", newVal)){ - if(grepl("variableName", key)){ - deleteTheseTS <- c(deleteTheseTS, lipdTS[[as.numeric(rowNum)]]$paleoData_TSid) - }else{ - lipdTS[[as.numeric(rowNum)]][eval(names(df1)[4])] <- NULL - } - }else{ - lipdTS[[as.numeric(rowNum)]][eval(names(df1)[4])] <- newVal - } - } - } - } - } - } - }else{ - df0 <- returns$returns1$synonymDF - df10 <- returns$returns2$noSynonym - for (j in 1:nrow(df0)){ - rowNum <- df0$rowNum[j] - newVal <- df0$New[j] - if(!is.na(rowNum) & length(rowNum) > 0){ - if (grepl("delete", newVal)){ - if(grepl("variableName", key)){ - deleteTheseTS <- c(deleteTheseTS, lipdTS[[as.numeric(rowNum)]]$paleoData_TSid) - }else{ - lipdTS[[as.numeric(rowNum)]][eval(names(df0)[4])] <- NULL - } - }else{ - lipdTS[[as.numeric(rowNum)]][eval(names(df0)[4])] <- newVal - } - } - } - } -# -# allTerms <- pullTsVariable(lipdTS, eval(names(df1)[4])) -# -# for (i in 1:length(allTerms)){ -# if(grepl("delete", allTerms[i])){ -# TS2$TS[[i]] <- NULL -# } -# } - - - - - - returns <- list("TS"=lipdTS, "synonymDF" = df0, "deleteTheseTS" = deleteTheseTS, "noSynonym" = df10) - - return(returns) -} - - -#Delete misnamed terms and TS with bad variableName - - - - -#Update notes based on results from `updateMetaDataFromStandardTables()` and `standardizeValue()` - - -#metadataChangesDF <- updateMetaDataFromStandardTables(TS, "paleoData_variableName")$ChangesDF -#standardizeSynonymDF <- standardizeValue(TS, "paleoData_variableName")$synonymDF -#updateNotes(TS, metadataChangesDF, standardizeSynonymDF) - -#' Update notes and paleoData_notes -#' -#' @param lipdTS a LiPD TS object -#' @param metadataChangesDF a data frame listing the changes to the metadata -#' @param standardizeSynonymDF standardizing synonyms dataframe -#' @param key which key -#' @param deleteTheseTS what to delete -#' -#' @return lipdTS -updateNotes <- function(lipdTS, key=NA, metadataChangesDF=NA, standardizeSynonymDF=NA, deleteTheseTS=NA){ - - - standardTables <- getStandardTables() - - #choose the appropriate notes - #for each invalid value from metadataChangesDF, update notes - if(is.na(key)){ - if(all(is.na(standardizeSynonymDF))){ - stop("Must explicitly enter key if not entering standardizeSynonymDF!") - } - key=names(standardizeSynonymDF)[4] - } - if(!all(is.na(standardizeSynonymDF)) & length(standardizeSynonymDF)>0 & !is.null(standardizeSynonymDF)){ - if(nrow(standardizeSynonymDF)>0){ - - standardizeSynonymDF <- - standardizeSynonymDF[apply(standardizeSynonymDF, - 1, - function(x) sum(is.na(x)))!=ncol(standardizeSynonymDF),] - } - } - - if (sub("\\_.*", "", key) == "paleoData") { - - - - if(!all(is.na(standardizeSynonymDF))){ - - for (i in 1:nrow(standardizeSynonymDF)){ - if(is.null(lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$paleoData_notes)){ - lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$paleoData_notes <- NA - } - newNote <- paste(sub("\\Orig.*", "", names(standardizeSynonymDF)[4]), - "updated", - sep = " ") - lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$paleoData_notes <- - paste(lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$paleoData_notes, - newNote, - sep = "; ") - - } - } - - if(!all(is.na(metadataChangesDF))){ - for (i in 1:nrow(metadataChangesDF)){ - if(is.null(lipdTS[[as.numeric(metadataChangesDF$rowNum[i])]]$paleoData_notes)){ - lipdTS[[as.numeric(metadataChangesDF$rowNum[i])]]$paleoData_notes <- NA - } - #Look at each row of the changesDF for values that are not NA or NULL - colNames <- names(metadataChangesDF) - for (j in 2:(ncol(metadataChangesDF))){ - valsChanged <- metadataChangesDF[i,j] - if (!is.na(valsChanged) & length(valsChanged)>0){ - valsChanged <- colNames[j] - #valsChanged <- paste(valsChanged, collapse=" ") - newNote <- paste(valsChanged, - "has been standardized", - sep = " ") - lipdTS[[as.numeric(i)]]$paleoData_notes <- - paste(lipdTS[[as.numeric(i)]]$paleoData_notes, - newNote, - sep = "; ") - } - } - } - } - - - message("Updated metadata for ", nrow(metadataChangesDF), " TS objects, - Standardized values for ", nrow(standardizeSynonymDF), " TS Objects") - - }else{ - - - if(!all(is.na(standardizeSynonymDF))){ - - for (i in 1:nrow(standardizeSynonymDF)){ - if(is.null(lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$notes)){ - lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$notes <- NA - } - newNote <- paste(sub("\\Orig.*", "", names(standardizeSynonymDF)[4]), - "updated", - sep = " ") - lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$notes <- - paste(lipdTS[[as.numeric(standardizeSynonymDF$rowNum[i])]]$notes, - newNote, - sep = "; ") - - } - } - - - - } - - numDelete <- 0 - for (i in 1:length(lipdTS)){ - if(i > length(lipdTS)){ - }else{ - if (lipdTS[[i]]$paleoData_TSid %in% deleteTheseTS){ - numDelete <- numDelete+1 - lipdTS[[i]] <- NULL - } - } - } - - for (i in 1:length(lipdTS)){ - lipdTS[[i]]$paleoData_notes <- sub("^; ", "", lipdTS[[i]]$paleoData_notes) - lipdTS[[i]]$paleoData_notes <- sub("^NA; ", "", lipdTS[[i]]$paleoData_notes) - lipdTS[[i]]$Notes <- sub("^; ", "", lipdTS[[i]]$Notes) - lipdTS[[i]]$Notes <- sub("^NA; ", "", lipdTS[[i]]$Notes) - } - - message("Updated metadata for ", nrow(metadataChangesDF), " TS objects,\n", - "Standardized values for ", nrow(standardizeSynonymDF), " TS Objects,\n", - "Deleted ", numDelete, " objects\n") - - - return(lipdTS) -} - -getAllTsNames <- function(TS){ - return(sort(unique(unlist(purrr::map(TS,names))))) -} - -standardizeAll <- function(TS,allKeys = names(standardTables)){ -notesOut <- list() - an <- getAllTsNames(TS) - - - toStandardize <- setdiff(allKeys,"paleoData_proxyGeneral") - - for(tc in toStandardize){ - - TS1 <- updateMetaDataFromStandardTables(TS, tc) - if(sum(unlist(lapply(TS1$TS, function(x) sum(is.na(names(x))))))>0){ - stop("NA is a TS key") - } - TS2 <- standardizeValue(lipdTS=TS1$TS, key=tc) - if(sum(unlist(lapply(TS2, function(x) sum(is.na(names(x))))))>0){ - stop("NA is a TS key") - } - TS <- TS2$TS - - if(tc == "interpretation_seasonality"){ - tci <- an[stringr::str_detect(an,"interpretation\\d{1,}_seasonality$")] - }else if(tc == "interpretation_variable"){ - tci <- an[stringr::str_detect(an,"interpretation\\d{1,}_variable$")] - }else{ - tci <- tc - } - - - for(tcii in tci){ - - - if(length(tci) > 1){ - an1 <- purrr::map_chr(TS2$synonymDF,\(x) names(x)[[4]]) - ws <- which(an1 == tcii) - - ssDF <- TS2$returns1[[ws]]$synonymDF - nsDF <- TS2$returns2[[ws]]$noSynonym - }else{ - ssDF <- TS2$synonymDF$synonymDF - nsDF <- TS2$noSynonym$noSynonym - } - - - TS <- updateNotes(key = tcii, - lipdTS = TS, - metadataChangesDF = TS1$ChangesDF, - deleteTheseTS = TS2$deleteTheseTS, - standardizeSynonymDF=ssDF) - if(sum(unlist(lapply(TS, function(x) sum(is.na(names(x))))))>0){ - stop("NA is a TS key") - } - - notesOut[[tcii]] <- list(metadata.changes = TS1$ChangesDF, deleted.ts = TS2$deleteTheseTS, standardized.synonym = ssDF, noSynonym = nsDF) - - if (length(nsDF)>0){ - message("Could not find valid names for ", nrow(nsDF), " values in ", tcii) - } - - - } - validNew <- isValidValue(TS, tc) - - # unrec <- sum(unlist(lapply(notesOut, function(x) nrow(x$noSynonym)))) - # - # - # if (unrec > 0){ - # message(unrec, " values not recognized for: ", tc) - # } - # - # if (methods::is(validNew, "list")){ - # invalid1 <- sum(unlist(lapply(validNew, function(x) nrow(x)))) - # }else{ - # invalid1 <- nrow(validNew) - # } - # - # - # if (invalid1 != unrec){ - # warning(paste0("Some invalid values not accounted for:\n", - # "noSynonym = ", unrec, "\n", - # "invalid = ", invalid1, "\n", - # "for key: ", tc)) - # } - - - - - - } - returns <- list(TS, notesOut) - return(returns) -} - -#' Are all the parameters valid? -#' -#' @param TS lipd-ts object -#' @param report report out? T/F -#' @param allKeys what keys to check -#' -#' @return boolean -#' @export -isValidAll <- function(TS,report = TRUE,allKeys = names(standardTables)){ - vo <- list() - an <- getAllTsNames(TS) - - toStandardize <- setdiff(allKeys,"paleoData_proxyGeneral") - - for(tc in toStandardize){ - print(tc) - vo[[tc]] <- isValidValue(TS, tc) - } - - if(report){ - return(vo) - }else{ - return(purrr::map_dbl(vo,numInvalid)) - } -} - - -numInvalid <- function(x){ - if(is(x,"data.frame")){ - return(nrow(x)) - }else{ - return(sum(map_dbl(x,nrow))) - } -} - - - - - diff --git a/man/cbind.NA.Rd b/man/cbind.NA.Rd new file mode 100644 index 0000000..2e010d2 --- /dev/null +++ b/man/cbind.NA.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cbind_NA.R +\name{cbind.NA} +\alias{cbind.NA} +\title{handle NAs in cbind} +\usage{ +\method{cbind}{`NA`}(..., fill = NA) +} +\arguments{ +\item{...}{whatever you're binding} + +\item{fill}{unused parameter} +} +\value{ +bound columns +} +\description{ +handle NAs in cbind +} diff --git a/man/checkKey.Rd b/man/checkKey.Rd deleted file mode 100644 index 1b2ff68..0000000 --- a/man/checkKey.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardization.R -\name{checkKey} -\alias{checkKey} -\title{Check all values of a given key for validity in appropriate spreadsheet} -\usage{ -checkKey(lipdTS, key, keyGeneral) -} -\arguments{ -\item{lipdTS}{a lipdTS object} - -\item{key}{key name} - -\item{keyGeneral}{generalized key name} -} -\value{ -invalidDF -} -\description{ -Check all values of a given key for validity in appropriate spreadsheet -} diff --git a/man/getStandardTables.Rd b/man/getStandardTables.Rd deleted file mode 100644 index 52ab0f3..0000000 --- a/man/getStandardTables.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardization.R -\name{getStandardTables} -\alias{getStandardTables} -\title{Get Standard tables} -\usage{ -getStandardTables() -} -\description{ -Get Standard tables -} diff --git a/man/isValidAll.Rd b/man/isValidAll.Rd deleted file mode 100644 index 5c1c54f..0000000 --- a/man/isValidAll.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardization.R -\name{isValidAll} -\alias{isValidAll} -\title{Are all the parameters valid?} -\usage{ -isValidAll(TS, report = TRUE, allKeys = names(standardTables)) -} -\arguments{ -\item{TS}{lipd-ts object} - -\item{report}{report out? T/F} - -\item{allKeys}{what keys to check} -} -\value{ -boolean -} -\description{ -Are all the parameters valid? -} diff --git a/man/isValidValue.Rd b/man/isValidValue.Rd deleted file mode 100644 index a0d1c28..0000000 --- a/man/isValidValue.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardization.R -\name{isValidValue} -\alias{isValidValue} -\title{make sure all terms under a controlled key are valid} -\usage{ -isValidValue(lipdTS, key = NA) -} -\arguments{ -\item{lipdTS}{a lipd-ts object} - -\item{key}{the key that you want to check} -} -\value{ -invalid keys df -} -\description{ -make sure all terms under a controlled key are valid -} diff --git a/man/pullTsVariable.Rd b/man/pullTsVariable.Rd index 206d2da..5b1494e 100644 --- a/man/pullTsVariable.Rd +++ b/man/pullTsVariable.Rd @@ -22,8 +22,8 @@ pulls all instances of a single variable out of a TS \seealso{ Other LiPD manipulation: \code{\link{pushTsVariable}()}, -\code{\link{tidyTsOld}()}, \code{\link{tidyTs}()}, +\code{\link{tidyTsOld}()}, \code{\link{untidyTs}()} } \concept{LiPD manipulation} diff --git a/man/pushTsVariable.Rd b/man/pushTsVariable.Rd index 93699e8..620fb29 100644 --- a/man/pushTsVariable.Rd +++ b/man/pushTsVariable.Rd @@ -24,8 +24,8 @@ pulls all instances of a single variable out of a TS \seealso{ Other LiPD manipulation: \code{\link{pullTsVariable}()}, -\code{\link{tidyTsOld}()}, \code{\link{tidyTs}()}, +\code{\link{tidyTsOld}()}, \code{\link{untidyTs}()} } \concept{LiPD manipulation} diff --git a/man/standardizeValue.Rd b/man/standardizeValue.Rd deleted file mode 100644 index 500a70a..0000000 --- a/man/standardizeValue.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardization.R -\name{standardizeValue} -\alias{standardizeValue} -\title{standardize terms automatically based on known synonyms} -\usage{ -standardizeValue(lipdTS, key = NA) -} -\arguments{ -\item{lipdTS}{a lipd TS object} - -\item{key}{the key to check} -} -\value{ -updated TS -} -\description{ -standardize terms automatically based on known synonyms -} diff --git a/man/untidyTs.Rd b/man/untidyTs.Rd index 19066fa..8fe2918 100644 --- a/man/untidyTs.Rd +++ b/man/untidyTs.Rd @@ -21,7 +21,7 @@ takes a long, tidy, data.frame and returns a TS object. This is the opposite of Other LiPD manipulation: \code{\link{pullTsVariable}()}, \code{\link{pushTsVariable}()}, -\code{\link{tidyTsOld}()}, -\code{\link{tidyTs}()} +\code{\link{tidyTs}()}, +\code{\link{tidyTsOld}()} } \concept{LiPD manipulation} diff --git a/man/updateMetaDataFromStandardTables.Rd b/man/updateMetaDataFromStandardTables.Rd deleted file mode 100644 index 700d5be..0000000 --- a/man/updateMetaDataFromStandardTables.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardization.R -\name{updateMetaDataFromStandardTables} -\alias{updateMetaDataFromStandardTables} -\title{grab metaData for given key from standard tables} -\usage{ -updateMetaDataFromStandardTables(lipdTS, key) -} -\arguments{ -\item{lipdTS}{a lipd TS object} - -\item{key}{the key to check} -} -\value{ -list -} -\description{ -grab metaData for given key from standard tables -} diff --git a/man/updateNotes.Rd b/man/updateNotes.Rd deleted file mode 100644 index f6d8af0..0000000 --- a/man/updateNotes.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/standardization.R -\name{updateNotes} -\alias{updateNotes} -\title{Update notes and paleoData_notes} -\usage{ -updateNotes( - lipdTS, - key = NA, - metadataChangesDF = NA, - standardizeSynonymDF = NA, - deleteTheseTS = NA -) -} -\arguments{ -\item{lipdTS}{a LiPD TS object} - -\item{key}{which key} - -\item{metadataChangesDF}{a data frame listing the changes to the metadata} - -\item{standardizeSynonymDF}{standardizing synonyms dataframe} - -\item{deleteTheseTS}{what to delete} -} -\value{ -lipdTS -} -\description{ -Update notes and paleoData_notes -} diff --git a/vignettes/Summary.Rmd b/vignettes/Summary.Rmd index aa00fdc..0012517 100644 --- a/vignettes/Summary.Rmd +++ b/vignettes/Summary.Rmd @@ -25,9 +25,7 @@ LiPD datasets can contain a lot of data and metadata, and it's often useful to g Let's first grab at a single LiPD the Moose Lake dataset from Clegg et al. (2010) that's part of the PAGES2k Temperature compilation. ```{r echo=T, results='hide'} -#library(lipdR) -devtools::load_all() - +library(lipdR) L <- readLipd("https://lipdverse.org/data/MD6jkgwSxsq0oilgYUjM/1_0_0//Arc-MooseLake.Clegg.2010-ensemble.lpd") ``` diff --git a/vignettes/lipd2neotoma.Rmd b/vignettes/lipd2neotoma.Rmd index f69ad24..77952bf 100644 --- a/vignettes/lipd2neotoma.Rmd +++ b/vignettes/lipd2neotoma.Rmd @@ -1,8 +1,12 @@ --- -title: "LiPD to Neotoma" +title: "Neotoma to LiPD" author: "Dave Edge" date: "2023-01-09" -output: html_document +vignette: > + %\VignetteIndexEntry{Neotoma To LiPD} + %\VignetteEngine{knitr::knitr} + %\VignetteEncoding{UTF-8} +output: rmarkdown::html_vignette --- ```{r setup, include=FALSE}