.nextPartyID<-function(target) {
if(length(target@parties)==0) return("1")
return(as.character(as.numeric(names(target@parties)[length(target@parties)])+1))
}
.nextProjectID<-function(target) {
if(length(target@projects)==0) return("1")
return(as.character(as.numeric(names(target@projects)[length(target@projects)])+1))
}
.nextPlotID<-function(target) {
if(length(target@plots)==0) return("1")
return(as.character(as.numeric(names(target@plots)[length(target@plots)])+1))
}
.nextPlotObservationID<-function(target) {
if(length(target@plotObservations)==0) return("1")
return(as.character(as.numeric(names(target@plotObservations)[length(target@plotObservations)])+1))
}
.nextStratumID<-function(target) {
if(length(target@strata)==0) return("1")
return(as.character(as.numeric(names(target@strata)[length(target@strata)])+1))
}
.nextSurfaceTypeID<-function(target) {
if(length(target@surfaceTypes)==0) return("1")
return(as.character(as.numeric(names(target@surfaceTypes)[length(target@surfaceTypes)])+1))
}
.nextStratumObservationID<-function(target) {
if(length(target@stratumObservations)==0) return("1")
return(as.character(as.numeric(names(target@stratumObservations)[length(target@stratumObservations)])+1))
}
.nextSurfaceCoverObservationID<-function(target) {
if(length(target@surfaceCoverObservations)==0) return("1")
return(as.character(as.numeric(names(target@surfaceCoverObservations)[length(target@surfaceCoverObservations)])+1))
}
.nextAggregateOrganismObservationID<-function(target) {
if(length(target@aggregateObservations)==0) return("1")
return(as.character(as.numeric(names(target@aggregateObservations)[length(target@aggregateObservations)])+1))
}
.nextIndividualOrganismID<-function(target) {
if(length(target@individualOrganisms)==0) return("1")
return(as.character(as.numeric(names(target@individualOrganisms)[length(target@individualOrganisms)])+1))
}
.nextIndividualOrganismObservationID<-function(target) {
if(length(target@individualObservations)==0) return("1")
return(as.character(as.numeric(names(target@individualObservations)[length(target@individualObservations)])+1))
}
.nextCommunityObservationID<-function(target) {
if(length(target@communityObservations)==0) return("1")
return(as.character(as.numeric(names(target@communityObservations)[length(target@communityObservations)])+1))
}
.nextSiteObservationID<-function(target) {
if(length(target@siteObservations)==0) return("1")
return(as.character(as.numeric(names(target@siteObservations)[length(target@siteObservations)])+1))
}
.nextLiteratureCitationID<-function(target) {
if(length(target@literatureCitations)==0) return("1")
return(as.character(as.numeric(names(target@literatureCitations)[length(target@literatureCitations)])+1))
}
.nextMethodID<-function(target) {
if(length(target@methods)==0) return("1")
return(as.character(as.numeric(names(target@methods)[length(target@methods)])+1))
}
.nextAttributeID<-function(target) {
if(length(target@attributes)==0) return("1")
return(as.character(as.numeric(names(target@attributes)[length(target@attributes)])+1))
}
.nextOrganismNameID<-function(target) {
if(length(target@organismNames)==0) return("1")
return(as.character(as.numeric(names(target@organismNames)[length(target@organismNames)])+1))
}
.nextTaxonConceptID<-function(target) {
if(length(target@taxonConcepts)==0) return("1")
return(as.character(as.numeric(names(target@taxonConcepts)[length(target@taxonConcepts)])+1))
}
.nextOrganismIdentityID<-function(target) {
if(length(target@organismIdentities)==0) return("1")
return(as.character(as.numeric(names(target@organismIdentities)[length(target@organismIdentities)])+1))
}
.nextIndividualOrganismLabelForPlot<-function(target, plotID) {
return(paste0("ind", .getNumberOfOrganismsByPlotID(target, plotID)+1))
}
# Returns the partyID for a new party in the data set or the ID of an existing party with the same name
.newPartyIDByName<-function(target, partyName) {
if(length(target@parties)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@parties)) {
if(target@parties[[i]]$name==partyName) return(list(id=names(target@parties)[i], new = FALSE))
}
return(list(id = .nextPartyID(target), new = TRUE))
}
# Returns the projectID for a new project in the data set or the ID of an existing project with the same title
.newProjectIDByTitle<-function(target, projectTitle) {
if(length(target@projects)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@projects)) {
if(target@projects[[i]]$title==projectTitle) return(list(id=names(target@projects)[i], new = FALSE))
}
return(list(id = .nextProjectID(target), new = TRUE))
}
# Returns the plotID for a new plot in the data set or the ID of an existing plot with the same name
.newPlotIDByName<-function(target, plotName) {
if(length(target@plots)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@plots)) {
if(target@plots[[i]]$plotName==plotName) return(list(id = names(target@plots)[i], new = FALSE))
}
return(list(id = .nextPlotID(target), new = TRUE))
}
# Returns the plotID for a new plot in the data set or the ID of an existing plot with the same name
.newPlotIDByNameAndUniqueIdentifier<-function(target, plotName, plotUniqueIdentifier) {
if(length(target@plots)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@plots)) {
if(!("plotUniqueIdentifier" %in% names(target@plots[[i]]))) {
if(target@plots[[i]]$plotName==plotName) return(list(id = names(target@plots)[i], new = FALSE))
} else if(plotUniqueIdentifier=="") { #If unique identifier is missing in both plots, compare names only
if((target@plots[[i]]$plotName==plotName) && (target@plots[[i]]$plotUniqueIdentifier==plotUniqueIdentifier)) return(list(id = names(target@plots)[i], new = FALSE))
}
}
return(list(id = .nextPlotID(target), new = TRUE))
}
# Returns the ID for a new plot observation in the data set or the ID of an existing plot observation
.newPlotObsIDByDate<-function(target, plotID, obsStartDate) {
obsStartDate = as.Date(obsStartDate)
if(length(target@plotObservations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@plotObservations)) {
if((target@plotObservations[[i]]$plotID==plotID) && (target@plotObservations[[i]]$obsStartDate==obsStartDate)) return(list(id = names(target@plotObservations)[i], new = FALSE))
}
return(list(id = .nextPlotObservationID(target), new = TRUE))
}
# Returns the ID for a new stratum in the data set or the ID of an existing stratum
.newStratumIDByName<-function(target, methodID, stratumName) {
if(length(target@strata)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@strata)) {
if((target@strata[[i]]$methodID==methodID) && (target@strata[[i]]$stratumName==stratumName)) return(list(id = names(target@strata)[i], new = FALSE))
}
return(list(id = .nextStratumID(target), new = TRUE))
}
# Returns the ID for a new stratum observation in the data set or the ID of an existing stratum observation
.newStratumObsIDByIDs<-function(target, plotObservationID, stratumID) {
if(length(target@stratumObservations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@stratumObservations)) {
if((target@stratumObservations[[i]]$plotObservationID==plotObservationID) && (target@stratumObservations[[i]]$stratumID==stratumID)) return(list(id = names(target@stratumObservations)[i], new = FALSE))
}
return(list(id = .nextStratumObservationID(target), new = TRUE))
}
# Returns the ID for a new surface type in the data set or the ID of an existing surface type
.newSurfaceTypeIDByName<-function(target, methodID, surfaceName) {
if(length(target@surfaceTypes)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@surfaceTypes)) {
if((target@surfaceTypes[[i]]$methodID==methodID) && (target@surfaceTypes[[i]]$surfaceName==surfaceName)) return(list(id = names(target@surfaceTypes)[i], new = FALSE))
}
return(list(id = .nextSurfaceTypeID(target), new = TRUE))
}
# Returns the ID for a new surface cover observation in the data set or the ID of an existing one
.newSurfaceCoverObsIDByIDs<-function(target, plotObservationID, surfaceTypeID) {
if(length(target@surfaceCoverObservations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@surfaceCoverObservations)) {
if((target@surfaceCoverObservations[[i]]$plotObservationID==plotObservationID) && (target@surfaceCoverObservations[[i]]$surfaceTypeID==surfaceTypeID)) return(list(id = names(target@surfaceCoverObservations)[i], new = FALSE))
}
return(list(id = .nextSurfaceCoverObservationID(target), new = TRUE))
}
# Returns the ID for a new aggregate organism observation in the data set or the ID of an existing aggregate organism observation
.newAggregateOrganismObservationIDByOrganismIdentityID<-function(target, plotObservationID, stratumObservationID, oiID) {
if(length(target@aggregateObservations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@aggregateObservations)) {
if((target@aggregateObservations[[i]]$plotObservationID==plotObservationID) &&
(target@aggregateObservations[[i]]$stratumObservationID==stratumObservationID) &&
(target@aggregateObservations[[i]]$organismIdentity==oiID))
return(list(id = names(target@aggregateObservations)[i], new = FALSE))
}
return(list(id = .nextAggregateOrganismObservationID(target), new = TRUE))
}
# Returns the ID for a new individual organism in the data set or the ID of an existing organism
.newIndividualOrganismIDByIndividualOrganismLabel<-function(target, plotID, individualOrganismLabel) {
if(length(target@individualOrganisms)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@individualOrganisms)) {
if((target@individualOrganisms[[i]]$plotID==plotID) && (target@individualOrganisms[[i]]$individualOrganismLabel==individualOrganismLabel)) return(list(id = names(target@individualOrganisms)[i], new = FALSE))
}
return(list(id = .nextIndividualOrganismID(target), new = TRUE))
}
# Returns the ID for a new individual organism observation in the data set or the ID of an existing organism observation
.newIndividualOrganismObservationIDByIndividualID<-function(target, plotObservationID, individualOrganismID) {
if(length(target@individualObservations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@individualObservations)) {
if((target@individualObservations[[i]]$plotObservationID==plotObservationID) && (target@individualObservations[[i]]$individualOrganismID==individualOrganismID)) return(list(id = names(target@individualObservations)[i], new = FALSE))
}
return(list(id = .nextIndividualOrganismObservationID(target), new = TRUE))
}
# Returns the ID for a new community observation in the data set or the ID of an existing community observation
.newCommunityObservationIDByID<-function(target, plotObservationID) {
if(length(target@communityObservations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@communityObservations)) {
if(target@communityObservations[[i]]$plotObservationID==plotObservationID) return(list(id = names(target@communityObservations)[i], new = FALSE))
}
return(list(id = .nextCommunityObservationID(target), new = TRUE))
}
# Returns the ID for a new site observation in the data set or the ID of an existing site observation
.newSiteObservationIDByID<-function(target, plotObservationID) {
if(length(target@siteObservations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@siteObservations)) {
if(target@siteObservations[[i]]$plotObservationID==plotObservationID) return(list(id = names(target@siteObservations)[i], new = FALSE))
}
return(list(id = .nextSiteObservationID(target), new = TRUE))
}
# Returns the ID for a new method in the data set or the ID of an existing method with the same name
.newMethodIDByName<-function(target, methodName) {
if(length(target@methods)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@methods)) {
if(target@methods[[i]]$name==methodName) return(list(id = names(target@methods)[i], new = FALSE))
}
return(list(id = .nextMethodID(target), new = TRUE))
}
# Returns the ID for a new literature citation in the data set or the ID of an existing one with the same string
.newLiteratureCitationIDByCitationString<-function(target, citationString) {
if(length(target@literatureCitations)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@literatureCitations)) {
if(target@literatureCitations[[i]]$citationString==citationString) return(list(id = names(target@literatureCitations)[i], new = FALSE))
}
return(list(id = .nextLiteratureCitationID(target), new = TRUE))
}
# Returns the ID for a new organism name in the data set or the ID of an existing organismName with the same name
.newOrganismNameIDByName<-function(target, organismName, taxon) {
if(length(target@organismNames)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@organismNames)) {
if((target@organismNames[[i]]$name==organismName) && (target@organismNames[[i]]$taxon==taxon)) return(list(id = names(target@organismNames)[i], new = FALSE))
}
return(list(id = .nextOrganismNameID(target), new = TRUE))
}
.newTaxonConceptIDByNameCitation<-function(target, organismName, citationString) {
if(length(target@taxonConcepts)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@taxonConcepts)) {
on = target@organismNames[[target@taxonConcepts[[i]]$organismNameID]]$name
cs = target@literatureCitations[[target@taxonConcepts[[i]]$accordingToCitationID]]$citationString
if(length(organismName)>1) stop("Organism name has length > 1.\n")
if((on==organismName) && (cs==citationString)) {
return(list(id = names(target@taxonConcepts)[i], new = FALSE))
}
}
return(list(id = .nextTaxonConceptID(target), new = TRUE))
}
# Returns the ID for a new organism identity in the data set or the ID of an existing organism identity with the same taxon concept
.newOrganismIdentityIDByTaxonConcept<-function(target, organismName, citationString) {
if(length(target@organismIdentities)==0) return(list(id="1", new = TRUE))
for(i in 1:length(target@organismIdentities)) {
on = .getOrganismIdentityName(target, i)
citString = .getOrganismIdentityCitationString(target, i)
if((on==organismName) && (citString == citationString)) {
return(list(id = names(target@organismIdentities)[i], new = FALSE))
}
}
return(list(id = .nextOrganismIdentityID(target), new = TRUE))
}
.getOrganismIdentityName<-function(target, identityID) {
oi = target@organismIdentities[[identityID]]
if("preferredTaxonNomenclature" %in% names(oi)) {
oriName = target@organismNames[[oi$preferredTaxonNomenclature$preferredTaxonNameID]]$name
} else {
oriName = target@organismNames[[oi$originalOrganismNameID]]$name
}
return(oriName)
}
.getOrganismIdentityCitationString<-function(target, identityID) {
citationString = ""
oi = target@organismIdentities[[identityID]]
if("originalConceptIdentification" %in% names(oi)) {
tc = target@taxonConcepts[[oi$originalConceptIdentification$taxonConceptID]]
citationString = target@literatureCitations[[tc$citationID]]$citationString
}
return(citationString)
}
.getIndividualOrganismIdentityName <-function(target, individualID){
return(.getOrganismIdentityName(target, target@individualOrganisms[[individualID]]$organismIdentityID))
}
# Counts the number of organisms by plot id
.getNumberOfOrganismsByPlotID<-function(target, plotID) {
indCount = 0
if(length(target@individualOrganisms)>0) {
for(i in 1:length(target@individualOrganisms)) {
if(target@individualOrganisms[[i]]$plotID==plotID) {
indCount = indCount + 1
}
}
}
return(indCount)
}
# Returns organism identities having the corresponding original organism name ID
.getOrganismIdentityIDsByOriginalOrganismNameID<-function(target, originalOrganismNameID) {
orgIdVec = character(0)
if(length(target@organismIdentities)>0) {
cnt = 1
for(i in 1:length(target@organismIdentities)) {
if(target@organismIdentities[[i]]$originalOrganismNameID==originalOrganismNameID) {
orgIdVec[cnt] = names(target@organismIdentities)[i]
cnt = cnt + 1
}
}
}
return(orgIdVec)
}
# Returns strata names corresponding to the input method
.getAttributeCodesByMethodID<-function(target, methodID) {
attVec = character(0)
if(length(target@attributes)>0) {
cnt = 1
for(i in 1:length(target@attributes)) {
if(target@attributes[[i]]$methodID==methodID) {
if(target@attributes[[i]]$type != "quantitative") {
attVec[cnt] = target@attributes[[i]]$code
cnt = cnt + 1
}
}
}
}
return(attVec)
}
# Returns strata names corresponding to the input method
.getAttributeIDsByMethodID<-function(target, methodID) {
attVec = character(0)
if(length(target@attributes)>0) {
cnt = 1
for(i in 1:length(target@attributes)) {
if(target@attributes[[i]]$methodID==methodID) {
attVec[cnt] = names(target@attributes)[i]
cnt = cnt + 1
}
}
}
return(attVec)
}
# Returns strata names corresponding to the input method
.getStratumNamesByMethodID<-function(target, methodID) {
strVec = character(0)
if(length(target@strata)>0) {
cnt = 1
for(i in 1:length(target@strata)) {
if(target@strata[[i]]$methodID==methodID) {
strVec[cnt] = target@strata[[i]]$stratumName
cnt = cnt + 1
}
}
}
return(strVec)
}
# Returns strata IDs corresponding to the input method
.getStratumIDsByMethodID<-function(target, methodID) {
strVec = character(0)
if(length(target@strata)>0) {
cnt = 1
for(i in 1:length(target@strata)) {
if(target@strata[[i]]$methodID==methodID) {
strVec[cnt] = names(target@strata)[i]
cnt = cnt + 1
}
}
}
return(strVec)
}
# Returns surface type IDs corresponding to the input method
.getSurfaceTypeIDsByMethodID<-function(target, methodID) {
stVec = character(0)
if(length(target@surfaceTypes)>0) {
cnt = 1
for(i in 1:length(target@surfaceTypes)) {
if(target@surfaceTypes[[i]]$methodID==methodID) {
stVec[cnt] = names(target@surfaceTypes)[i]
cnt = cnt + 1
}
}
}
return(stVec)
}
# Returns surafce names corresponding to the input method
.getSurfaceTypeNamesByMethodID<-function(target, methodID) {
sVec = character(0)
if(length(target@surfaceTypes)>0) {
cnt = 1
for(i in 1:length(target@surfaceTypes)) {
if(target@surfaceTypes[[i]]$methodID==methodID) {
sVec[cnt] = target@surfaceTypes[[i]]$surfaceName
cnt = cnt + 1
}
}
}
return(sVec)
}
.getNumberOfSubPlots<-function(target) {
cnt = 0
if(length(target@plots)>0) {
for(i in 1:length(target@plots)) {
if("parentPlotID" %in% names(target@plots[[i]])) {
cnt = cnt + 1
}
}
}
return(cnt)
}
.getNumberOfPlotObservationsInSubPlots<-function(target) {
cnt = 0
if(length(target@plotObservations)>0) {
for(i in 1:length(target@plotObservations)) {
plot = target@plots[[target@plotObservations[[i]]$plotID]]
if("parentPlotID" %in% names(plot)) {
cnt = cnt + 1
}
}
}
return(cnt)
}
.applyMappingsToMethod<-function(method, litIDmap){
if("citationID" %in% names(method)) {
method$citationID = litIDmap[[method$citationID]]
}
return(method)
}
.applyMappingsToTaxonConcept<-function(taxonConcept, onIDmap, litIDmap){
if("organismNameID" %in% names(taxonConcept)) {
taxonConcept$organismNameID = onIDmap[[taxonConcept$organismNameID]]
}
if("accordingToCitationID" %in% names(taxonConcept)) {
taxonConcept$accordingToCitationID = litIDmap[[taxonConcept$accordingToCitationID]]
}
return(taxonConcept)
}
.applyMappingsToOrganismIdentity<-function(organismIdentity, onIDmap, tcIDmap){
if("originalOrganismNameID" %in% names(organismIdentity)) {
organismIdentity$originalOrganismNameID = onIDmap[[organismIdentity$originalOrganismNameID]]
}
if("originalConceptIdentification" %in% names(organismIdentity)) {
organismIdentity$originalConceptIdentification$taxonConceptID = tcIDmap[[organismIdentity$originalConceptIdentification$taxonConceptID]]
}
return(organismIdentity)
}
#Translate IDs in a project element
.applyMappingsToProject<-function(project, partyIDmap, litIDmap) {
n = names(project)
for(i in 1:length(n)) {
# Update party codes
if(n[[i]]=="personnel") project[[i]][[1]] = partyIDmap[[project[[i]][[1]]]]
if(n[[i]]=="documentCitationID") project[[i]] = litIDmap[[project[[i]]]]
}
return(project)
}
#Translate IDs in a plot element
.applyMappingsToPlot<-function(plot, partyIDmap, attIDmap) {
for(n in names(plot)) {
# Update party codes
if(n=="placementPartyID") plot[[n]] = partyIDmap[[plot[[n]]]]
# Update attribute codes
if(n %in% c("topography")) {
for(m in names(plot[[n]])) {
if(m %in% c("slope", "aspect"))
plot[[n]][[m]]$attributeID = attIDmap[[plot[[n]][[m]]$attributeID]]
}
}
}
return(plot)
}
.applyMappingsToIndividualOrganism<-function(indOrg, plotIDmap, oiIDmap) {
indOrg$plotID = plotIDmap[[indOrg$plotID]]
indOrg$organismIdentityID = oiIDmap[[indOrg$organismIdentityID]]
return(indOrg)
}
.applyMappingsToPlotObservation<-function(plotObs, plotIDmap, projectIDmap) {
plotObs$plotID = plotIDmap[[plotObs$plotID]]
if("projectID" %in% names(plotObs)) plotObs$projectID = projectIDmap[[plotObs[["projectID"]]]]
return(plotObs)
}
.applyMappingsToStratumObservation<-function(strobs, strIDmap, plotObsIDmap, attIDmap) {
strobs$stratumID = strIDmap[[strobs$stratumID]]
strobs$plotObservationID = plotObsIDmap[[strobs$plotObservationID]]
for(n in names(strobs)) {
if(n %in% c("stratumMeasurements")) {
for(i in 1:length(strobs[["stratumMeasurements"]])) {
strobs$stratumMeasurements[[i]]$attributeID = attIDmap[[strobs$stratumMeasurements[[i]]$attributeID]]
}
}
else if(n %in% c("lowerLimitMeasurement", "upperLimitMeasurement")) {
strobs[[n]]$attributeID = attIDmap[[strobs[[n]]$attributeID]]
}
}
return(strobs)
}
.applyMappingsToIndividualOrganismObservation<-function(indObs, plotObsIDmap, strObsIDmap, indIDmap, attIDmap) {
indObs$plotObservationID = plotObsIDmap[[indObs$plotObservationID]]
indObs$individualOrganismID = indIDmap[[indObs$individualOrganismID]]
if("stratumObservationID" %in% names(indObs)) {
indObs$stratumObservationID = strObsIDmap[[indObs$stratumObservationID]]
}
for(n in names(indObs)) {
# Update attribute codes
if(n %in% c("individualOrganismMeasurements")) {
for(i in 1:length(indObs[["individualOrganismMeasurements"]])) {
indObs$individualOrganismMeasurements[[i]]$attributeID = attIDmap[[indObs$individualOrganismMeasurements[[i]]$attributeID]]
}
}
else if(n %in% c("heightMeasurement", "diameterMeasurement")) {
indObs[[n]]$attributeID = attIDmap[[indObs[[n]]$attributeID]]
}
}
return(indObs)
}
.applyMappingsToAggregateOrganismObservation <-function(aggObs, plotObsIDmap, oiIDmap, strObsIDmap, attIDmap) {
if("plotObservationID" %in% names(aggObs)) {
if(aggObs$plotObservationID!="") {
aggObs$plotObservationID = plotObsIDmap[[aggObs$plotObservationID]]
}
} else {
aggObs$plotObservationID = ""
}
if("organismIdentityID" %in% names(aggObs)) {
if(aggObs$organismIdentityID!="") {
aggObs$organismIdentityID = oiIDmap[[aggObs$organismIdentityID]]
}
} else {
aggObs$organismIdentityID = ""
}
if("stratumObservationID" %in% names(aggObs)) {
if(aggObs$stratumObservationID!="") {
aggObs$stratumObservationID = strObsIDmap[[aggObs$stratumObservationID]]
}
} else {
aggObs$stratumObservationID = ""
}
for(n in names(aggObs)) {
# Update attribute codes
if(n %in% c("aggregateOrganismMeasurements")) {
for(i in 1:length(aggObs[["aggregateOrganismMeasurements"]])) {
aggObs$aggregateOrganismMeasurements[[i]]$attributeID = attIDmap[[aggObs$aggregateOrganismMeasurements[[i]]$attributeID]]
}
}
else if(n %in% c("heightMeasurement")) {
aggObs[[n]]$attributeID = attIDmap[[aggObs[[n]]$attributeID]]
}
}
return(aggObs)
}
.applyMappingsToCommunityObservation<-function(commobs, plotObsIDmap, attIDmap) {
commobs$plotObservationID = plotObsIDmap[[commobs$plotObservationID]]
# Update attribute codes
for(n in names(commobs)) {
if(n %in% c("communityMeasurements")) {
for(i in 1:length(commobs[[n]])) {
commobs[[n]][[i]]$attributeID = attIDmap[[commobs[[n]][[i]]$attributeID]]
}
}
}
return(commobs)
}
.applyMappingsToSiteObservation<-function(siteobs, plotObsIDmap, attIDmap) {
siteobs$plotObservationID = plotObsIDmap[[siteobs$plotObservationID]]
# Update attribute codes
for(n in names(siteobs)) {
if(n %in% c("soilMeasurements", "climateMeasurements", "waterBodyMeasurements")) {
for(i in 1:length(siteobs[[n]])) {
siteobs[[n]][[i]]$attributeID = attIDmap[[siteobs[[n]][[i]]$attributeID]]
}
}
}
return(siteobs)
}
.applyMappingsToSurfaceCoverObservation<-function(scobs, stIDmap, plotObsIDmap, attIDmap) {
scobs$surfaceTypeID = stIDmap[[scobs$surfaceTypeID]]
scobs$plotObservationID = plotObsIDmap[[scobs$plotObservationID]]
for(n in names(scobs)) {
if(n %in% c("coverMeasurement")) {
scobs[[n]]$attributeID = attIDmap[[scobs[[n]]$attributeID]]
}
}
return(scobs)
}
#Pools the information of two parties
.mergeParties<-function(par1, par2) {
n1 = names(par1)
n2 = names(par2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(par1[[n]]!=par2[[n]]) stop(paste0("Parties have different data for '", n, "'. Cannot merge."))
res[[n]] = par1[[n]]
} else if(n %in% n1) {
res[[n]] = par1[[n]]
} else if(n %in% n2) {
res[[n]] = par2[[n]]
}
}
return(res)
}
#Pools the information of two literature citations
.mergeLiteratureCitations<-function(cit1, cit2) {
n1 = names(cit1)
n2 = names(cit2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(cit1[[n]]!=cit2[[n]]) stop(paste0("Literature citations have different data for '", n, "'. Cannot merge."))
res[[n]] = cit1[[n]]
} else if(n %in% n1) {
res[[n]] = cit1[[n]]
} else if(n %in% n2) {
res[[n]] = cit2[[n]]
}
}
return(res)
}
#Pools the information of two methods
.mergeMethods<-function(met1, met2, litIDmap) {
n1 = names(met1)
n2 = names(met2)
met2 = .applyMappingsToMethod(met2, litIDmap)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(met1[[n]]!=met2[[n]]) stop(paste0("Methods have different data for '", n, "'. Cannot merge."))
res[[n]] = met1[[n]]
} else if(n %in% n1) {
res[[n]] = met1[[n]]
} else if(n %in% n2) {
res[[n]] = met2[[n]]
}
}
return(res)
}
#Pools the information of two strata
.mergeStrata<-function(str1, str2) {
n1 = names(str1)
n2 = names(str2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(str1[[n]]!=str2[[n]]) stop(paste0("Strata have different data for '", n, "'. Cannot merge."))
res[[n]] = str1[[n]]
} else if(n %in% n1) {
res[[n]] = str1[[n]]
} else if(n %in% n2) {
res[[n]] = str2[[n]]
}
}
return(res)
}
#Pools the information of two organism names
.mergeOrganismNames<-function(on1, on2) {
n1 = names(on1)
n2 = names(on2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(on1[[n]]!=on2[[n]]) stop(paste0("Organism names have different data for '", n, "'. Cannot merge."))
res[[n]] = on1[[n]]
} else if(n %in% n1) {
res[[n]] = on1[[n]]
} else if(n %in% n2) {
res[[n]] = on2[[n]]
}
}
return(res)
}
#Pools the information of two taxon concepts
.mergeTaxonConcepts<-function(tc1, tc2, onIDmap, litIDmap) {
n1 = names(tc1)
n2 = names(tc2)
tc2 = .applyMappingsToTaxonConcept(tc2, onIDmap, litIDmap)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(tc1[[n]]!=tc2[[n]]) stop(paste0("Organism names have different data for '", n, "'. Cannot merge."))
res[[n]] = tc1[[n]]
} else if(n %in% n1) {
res[[n]] = tc1[[n]]
} else if(n %in% n2) {
res[[n]] = tc2[[n]]
}
}
return(res)
}
#Pools the information of two organism identities
.mergeOrganismIdentities<-function(oi1, oi2, onIDmap, tcIDmap) {
n1 = names(oi1)
n2 = names(oi2)
oi2 = .applyMappingsToOrganismIdentity(oi2, onIDmap, tcIDmap)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(oi1[[n]]!=oi2[[n]]) stop(paste0("Organism identities have different data for '", n, "'. Cannot merge."))
res[[n]] = oi1[[n]]
} else if(n %in% n1) {
res[[n]] = oi1[[n]]
} else if(n %in% n2) {
res[[n]] = oi2[[n]]
}
}
return(res)
}
#Pools the information of two projects
.mergeProjects<-function(prj1, prj2) {
n1 = names(prj1)
n2 = names(prj2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(prj1[[n]]!=prj2[[n]]) stop(paste0("Projects have different data for '", n, "'. Cannot merge."))
res[[n]] = prj1[[n]]
} else if(n %in% n1) {
res[[n]] = prj1[[n]]
} else if(n %in% n2) {
res[[n]] = prj2[[n]]
}
}
return(res)
}
#Pools the information of two plots
.mergePlots<-function(plot1, plot2, partyIDmap, attIDmap) {
n1 = names(plot1)
n2 = names(plot2)
plot2 = .applyMappingsToPlot(plot2, partyIDmap, attIDmap)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(plot1[[n]]!=plot2[[n]]) stop(paste0("Plots have different data for '", n, "'. Cannot merge."))
res[[n]] = plot1[[n]]
} else if(n %in% n1) {
res[[n]] = plot1[[n]]
} else if(n %in% n2) {
res[[n]] = plot2[[n]]
}
}
return(res)
}
#Pools the information of two plot observations
.mergePlotObservations<-function(plotObservation1, plotObservation2) {
n1 = names(plotObservation1)
n2 = names(plotObservation2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(plotObservation1[[n]]!=plotObservation2[[n]]) stop(paste0("Plot observations have different data for '", n, "'. Cannot merge."))
res[[n]] = plotObservation1[[n]]
} else if(n %in% n1) {
res[[n]] = plotObservation1[[n]]
} else if(n %in% n2) {
res[[n]] = plotObservation2[[n]]
}
}
return(res)
}
#Pools the information of two organism identitys
.mergeOrganismIdentities<-function(oi1, oi2) {
n1 = names(oi1)
n2 = names(oi2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(oi1[[n]]!=oi2[[n]]) stop(paste0("Taxon name usage concepts have different data for '", n, "'. Cannot merge."))
res[[n]] = oi1[[n]]
} else if(n %in% n1) {
res[[n]] = oi1[[n]]
} else if(n %in% n2) {
res[[n]] = oi2[[n]]
}
}
return(res)
}
#Pools the information of two stratum observations
.mergeStratumObservations<-function(strobs1, strobs2) {
n1 = names(strobs1)
n2 = names(strobs2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(strobs1[[n]]!=strobs2[[n]]) stop(paste0("Stratum observations have different data for '", n, "'. Cannot merge."))
res[[n]] = strobs1[[n]]
} else if(n %in% n1) {
res[[n]] = strobs1[[n]]
} else if(n %in% n2) {
res[[n]] = strobs2[[n]]
}
}
return(res)
}
#Pools the information of two surface cover observations
.mergeSurfaceCoverObservations<-function(scobs1, scobs2) {
n1 = names(scobs1)
n2 = names(scobs2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(scobs1[[n]]!=scobs2[[n]]) stop(paste0("Surface cover observations have different data for '", n, "'. Cannot merge."))
res[[n]] = scobs1[[n]]
} else if(n %in% n1) {
res[[n]] = scobs1[[n]]
} else if(n %in% n2) {
res[[n]] = scobs2[[n]]
}
}
return(res)
}
#Pools the information of two aggregate organism observations
.mergeAggregateOrganismObservations<-function(aggobs1, aggobs2) {
n1 = names(aggobs1)
n2 = names(aggobs2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(aggobs1[[n]]!=aggobs2[[n]]) stop(paste0("Aggregate organism observations have different data for '", n, "'. Cannot merge."))
res[[n]] = aggobs1[[n]]
} else if(n %in% n1) {
res[[n]] = aggobs1[[n]]
} else if(n %in% n2) {
res[[n]] = aggobs2[[n]]
}
}
return(res)
}
#Pools the information of two individual organisms
.mergeIndividualOrganisms<-function(ind1, ind2) {
n1 = names(ind1)
n2 = names(ind2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(ind1[[n]]!=ind2[[n]]) stop(paste0("Individual organisms have different data for '", n, "'. Cannot merge."))
res[[n]] = ind1[[n]]
} else if(n %in% n1) {
res[[n]] = ind1[[n]]
} else if(n %in% n2) {
res[[n]] = ind2[[n]]
}
}
return(res)
}
#Pools the information of two individual organism observations
.mergeIndividualOrganismObservations<-function(indobs1, indobs2) {
n1 = names(indobs1)
n2 = names(indobs2)
npool = unique(c(n1,n2))
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
if(indobs1[[n]]!=indobs2[[n]]) stop(paste0("Individual organism observations have different data for '", n, "'. Cannot merge."))
res[[n]] = indobs1[[n]]
} else if(n %in% n1) {
res[[n]] = indobs1[[n]]
} else if(n %in% n2) {
res[[n]] = indobs2[[n]]
}
}
return(res)
}
# Pools the information of two site observations
# Measurements
.mergeCommunityObservations<-function(commobs1, commobs2) {
n1 = names(commobs1)
n2 = names(commobs2)
npool = unique(c(n1,n2)) # these are soilMeasurements, climateMeasurements, ...
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
res[[n]] = c(commobs1[[n]], commobs2[[n]])# add both vector elements to the result
} else if(n %in% n1) {
res[[n]] = commobs1[[n]]
} else if(n %in% n2) {
res[[n]] = commobs2[[n]]
}
}
return(res)
}
# Pools the information of two site observations
# Measurements
.mergeSiteObservations<-function(siteobs1, siteobs2) {
n1 = names(siteobs1)
n2 = names(siteobs2)
npool = unique(c(n1,n2)) # these are soilMeasurements, climateMeasurements, ...
res = list()
for(n in npool) {
if((n %in% n1) && (n %in% n2)) {
res[[n]] = c(siteobs1[[n]], siteobs2[[n]])# add both vector elements to the result
} else if(n %in% n1) {
res[[n]] = siteobs1[[n]]
} else if(n %in% n2) {
res[[n]] = siteobs2[[n]]
}
}
return(res)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.