Merge pull request #356 from StoXProject/datsusc

Fixed bugs in writeLevel().

.github/workflows/check-full.yaml

@@ -212,14 +212,14 @@ jobs:
       #### 4. Build the package source and binary files: ####
       #######################################################
 
-      - name: Build package source archive from branches testing and master
+      - name: Build package source archive from branches develop, testing and master
         if: runner.os == 'Linux' && matrix.config.r == 'release' && github.event_name == 'push' && (github.ref_name == 'master' || github.ref_name == 'testing' || github.ref_name == 'develop')
         run: |
           pkgbuild::build(".", dest_path = ".", binary = FALSE)
           system(paste0("PKG_FREL=", Sys.getenv("PKG_FILE"), " >> ", Sys.getenv("GITHUB_ENV")))
         shell: Rscript {0}
 
-      - name: Build package binary archive  from branches testing and master for Windows and macOS (this builds also on matrix.config.r = release, which can or can not be a duplicate)
+      - name: Build package binary archive from branches develop, testing and master for Windows and macOS (this builds also on matrix.config.r = release, which can or can not be a duplicate)
         if: (runner.os == 'Windows' || runner.os == 'macOS') && github.event_name == 'push' && (github.ref_name == 'master' || github.ref_name == 'testing' || github.ref_name == 'develop')
         run: |
           pkgbuild::build(".", dest_path = ".", binary = TRUE)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: RstoxData
-Version: 1.10.2-9005
-Date: 2023-12-06
+Version: 1.10.2-9006
+Date: 2023-12-22
 Title: Tools to Read and Manipulate Fisheries Data
 Authors@R: c(
   person(given = "Edvin", 

R/writeXmlFile.R

@@ -16,19 +16,20 @@ writeXmlDeclaration <- function(stream, version, encoding, standalone){
 
 #' @noRd
 openTag <- function(stream, tagname, attributes=NULL, indent=""){
-
-  tagstring <- paste0(indent, "<",tagname)
-  if (length(attributes)){
-    #stopifnot(nrow(attributes)==1)
-
-    for (n in names(attributes)){
-      if (!is.na(attributes[[n]][[1]])){
-        tagstring <- paste(tagstring, paste0(n,"=\"",attributes[[n]][[1]],"\""))
-      }
-    }
-  }
-  tagstring <- paste0(tagstring, ">")
-  writeLines(tagstring, con=stream, useBytes = T)
+	# Exclude NAs:
+	notNA <- !sapply(attributes, is.na)
+
+	# Build a string to write:
+	tagstring <- paste0(
+  		indent, 
+  		"<",
+  		tagname, 
+  		" ",
+  		paste(paste0(names(attributes[notNA]), "=\"", attributes[notNA], "\""), collapse = " "), 
+    	">"
+	)
+
+	writeLines(tagstring, con=stream, useBytes = T)
 }
 
 #' @noRd
@@ -39,70 +40,133 @@ closeTag <- function(stream, tagname, indent=""){
 
 #' @noRd
 writeSimpleTags <- function(stream, tags, indent=""){
-  string <- ""
-  for (n in names(tags)){
-    if (!is.na(tags[[n]][[1]])){
-      string <- paste0(string, "<",n,">",tags[[n]][[1]],"</",n,">")
-    }
-  }
-  writeLines(paste0(indent, string), con=stream, useBytes = T)
+
+	# Write only if non-empty:
+	if(NROW(tags)) {
+		# Create a list instead of a one row data table:
+		tags <- as.list(tags)
+
+		# Exclude NAs:
+		notNA <- !sapply(tags, is.na)
+
+		# The string to write:
+		string <- paste0(
+			"<",
+			names(tags[notNA]), 
+			">",
+			tags[notNA], 
+			"</",
+			names(tags[notNA]), 
+			">"	
+		)
+
+		writeLines(paste0(indent, string), con=stream, useBytes = T)
+	}
 }
 
 
+
+
+
 writeLevel <- function(stream, data, level, parentKeys, xsdObject, indent = "", namespace = "", keepEmptyLevels = FALSE){
-
-  # Get the data to write:
-  leveldata <- data[[level]]
-  if (NROW(leveldata) && length(parentKeys)){
-    leveldata <- leveldata[as.list(parentKeys), on = names(parentKeys), nomatch = NULL]
-  }
-
-  # Identify children:
-  children <- xsdObject$treeStruct[[level]]
-
-  # get keys
-  keys <- names(leveldata)[seq_len(xsdObject$prefixLens[[level]])]
-  attribsNames <- keys
-  if (!is.null(parentKeys)){
-    attribsNames <- attribsNames[!(attribsNames %in% names(parentKeys))]
-  }
-
-  if(level == xsdObject$root) {
-    rootAttribs <- c(xmlns = namespace)
-  }
-  else {
-    rootAttribs <- NULL
-  }
-  # write opening tag and attributes
-  if(NROW(leveldata)) {
-    for (i in seq_len(nrow(leveldata))){
-      openTag(stream, level, c(leveldata[i,.SD, .SDcols = attribsNames], rootAttribs), indent)
-
-      # write simple element tags
-      simpletags <- xsdObject$tableHeaders[[level]][!(xsdObject$tableHeaders[[level]] %in% keys)]
-      writeSimpleTags(stream, leveldata[i, .SD, .SDcols = simpletags], paste0(indent, "\t"))
-
-      # write complex element tags
-      for (ch in children){
-        writeLevel(stream, data, ch, leveldata[i, .SD, .SDcols = keys], xsdObject, paste0(indent, "\t"), keepEmptyLevels = keepEmptyLevels)
-      }
-
-      # write closing tag
-      closeTag(stream, level, indent)
-    }
-  }
-  else if(keepEmptyLevels || length(rootAttribs)){
-    openTag(stream, level, rootAttribs, indent)
-    for (sub in xsdObject$treeStruct[[level]]){
-      writeLevel(stream, data, sub, NULL, xsdObject, paste0(indent, "\t"), keepEmptyLevels = keepEmptyLevels)
-    }
-    closeTag(stream, level, indent)
-    #return()
-  }
-
+
+	if(level == xsdObject$root) {
+		rootAttribs <- c(xmlns = namespace)
+	}
+	else {
+		rootAttribs <- NULL
+	}
+
+	# get keys
+	keys <- names(data[[level]])[seq_len(xsdObject$prefixLens[[level]])]
+	attribsNames <- setdiff(keys, names(parentKeys))
+
+	# Identify children:
+	children <- xsdObject$treeStruct[[level]]
+
+	# Get the current data. If no parentKeys are given, keep the full table:
+	leveldata <- data[[level]]
+	if (NROW(leveldata)){
+		if(length(parentKeys)) {
+			leveldata <- leveldata[as.list(parentKeys), on = names(parentKeys), nomatch = NULL]
+		}
+	}
+
+	# write opening tag and attributes
+	if(NROW(leveldata)) {
+
+		# Use subset in the for loop, as it is faster than []:
+		subsetVector <- logical(nrow(leveldata))
+
+		for (i in seq_len(nrow(leveldata))){
+
+			thisSubsetVector <- subsetVector
+			thisSubsetVector[i] <- TRUE
+
+			# Write the openning tag:
+			openTag(
+				stream = stream, 
+				tagname = level, 
+				attributes = c(
+					subset(leveldata, subset = thisSubsetVector, select = attribsNames), 
+					rootAttribs
+				), 
+				indent = indent
+			)
+
+			# write simple element tags
+			simpletags <- setdiff(xsdObject$tableHeaders[[level]], keys)
+			writeSimpleTags(
+				stream = stream, 
+				tags = subset(leveldata, subset = thisSubsetVector, select = simpletags), 
+				indent = paste0(indent, "\t")
+			)
+
+
+			# write complex element tags
+			for (ch in children){
+				writeLevel(
+					stream = stream, 
+					data = data, 
+					level = ch, 
+					parentKeys = subset(leveldata, subset = thisSubsetVector, select = keys), 
+					xsdObject = xsdObject, 
+					indent = paste0(indent, "\t"), 
+					keepEmptyLevels = keepEmptyLevels
+				)
+			}
+
+			# write closing tag
+			closeTag(stream, level, indent)
+		}
+	}
+	# Write empyt levels, but not empty rows:
+	else if((keepEmptyLevels && !NROW(data[[level]])) || length(rootAttribs)){
+		openTag(stream, level, rootAttribs, indent)
+		for (sub in xsdObject$treeStruct[[level]]){
+			writeLevel(
+				stream = stream, 
+				data = data, 
+				level = sub, 
+				parentKeys = parentKeys, 
+				xsdObject = xsdObject, 
+				indent = paste0(indent, "\t"), 
+				keepEmptyLevels = keepEmptyLevels
+			)
+		}
+		closeTag(stream, level, indent)
+		#return()
+	}
+	else {
+		return()
+	}
+
 }
 
 
+
+
+
 #' converts everything to UTF-8 character before XML writing
 #' @noRd
 typeConvert <- function(dataTables, xsdObject){
@@ -289,7 +353,17 @@ writeXmlFile <- function(fileName, dataTables, xsdObject, namespace, encoding="U
 
   stream = file(fileName, open="w", encoding="native.enc")
   writeXmlDeclaration(stream, version=xmlStandard, encoding=encoding, standalone=T)
-  writeLevel(stream, dataTables, xsdObject$root, NULL, xsdObject, "", namespace, keepEmptyLevels = keepEmptyLevels)    
+  writeLevel(
+  	stream = stream, 
+  	data = dataTables, 
+  	level = xsdObject$root, 
+  	parentKeys = NULL, 
+  	xsdObject = xsdObject, 
+  	indent = "", 
+  	namespace = namespace, 
+  	keepEmptyLevels = keepEmptyLevels
+  )
+
     close(stream)
 
 }
@@ -579,7 +653,7 @@ WriteBioticOrAcoustic <- function(Data, DataType, FileNames = character(), names
       stop(paste("File", FileName, "already exists."))
     }
 
-    writeXmlFile(FileName, thisData, xsdObject, namespace, encoding, keepEmptyLevels = namespace == "http://www.imr.no/formats/nmdechosounder/v1")    
+    writeXmlFile(FileName, thisData, xsdObject, namespace, encoding, keepEmptyLevels = namespace == "http://www.imr.no/formats/nmdechosounder/v1")
   }
 
 }

data-raw/prepUnits.R

@@ -36,6 +36,7 @@ StoxUnits <- rbind(StoxUnits, list("length-nmi", "length", "M", "nmi", "nautical
 StoxUnits <- rbind(StoxUnits, list("cardinality-N", "cardinality", "N", "individuals", "individuals", 1))
 StoxUnits <- rbind(StoxUnits, list("cardinality-kN", "cardinality", "kN", "10^3 individuals", "thousand individuals", 1e3))
 StoxUnits <- rbind(StoxUnits, list("cardinality-MN", "cardinality", "MN", "10^6 individuals", "million individuals", 1e6))
+StoxUnits <- rbind(StoxUnits, list("cardinality-GN", "cardinality", "GN", "10^9 individuals", "billion individuals", 1e9))
 
 StoxUnits <- rbind(StoxUnits, list("area_number_density-N/nmi^2", "area_number_density", "N/nmi^2", "individuals/nmi^2", "individuals per square nautical mile", 1))
 StoxUnits <- rbind(StoxUnits, list("area_number_density-kN/nmi^2", "area_number_density", "kN/nmi^2", "10^3 individuals/nmi^2", "thousand individuals per square nautical mile", 1e3))