Fix bug and add tests for missing clade bug

This bug is triggered by defining a clade in a self closing "leaf"
tag. The fix is to avoid universally trating leaves an non-structural
but check if a leaf tag is a clade.

Author: MaybeJustJames

src/Bio/Phylogeny/Internal/PhyloXml.purs

@@ -391,7 +391,7 @@ toStructuralTree (Internal p@(XmlNode node) children) =
   -- Structural elements form the phylogeny,
   -- all other elements are attributes.
   isStructuralElement :: Tree XmlNode -> Boolean
-  isStructuralElement (Leaf _) = false
+  isStructuralElement (Leaf (XmlNode { name })) = name == "clade"
   isStructuralElement (Internal (XmlNode { name }) _) =
     A.elem name [ "phyloxml", "phylogeny", "clade" ]
 

test/Bio/Phylogeny/PhyloXml.purs

@@ -5,6 +5,7 @@ import Prelude
 import Bio.Phylogeny
   ( Attribute(..)
   , attributes
+  , edges
   , lookupNode
   , parsePhyloXml
   , reportError
@@ -29,6 +30,58 @@ specs = do
       text <- readTextFile UTF8 $ testDir </> "phyloxml_example1.xml"
       expectFail "No trees in this PhyloXML document" $ parsePhyloXml text
 
+    it "Parses a single node tree" do
+      let text = "<phyloxml><phylogeny><clade><name>A</name></clade></phylogeny></phyloxml>"
+      let phylogeny = parsePhyloXml text
+
+      (A.length <<< roots <$> phylogeny)
+        `shouldEqual`
+          (Right 1)
+
+      case phylogeny of
+        Right phylogeny' ->
+          (nodeName <$> (A.catMaybes (lookupNode phylogeny' <$> (roots phylogeny'))))
+            `shouldEqual`
+              [ ("A" /\ 0.0) ]
+        Left err -> fail $ reportError "" err
+
+    it "Parses a single node tree with name attribute" do
+      let text = "<phyloxml><phylogeny><clade name=\"A\" /></phylogeny></phyloxml>"
+      let phylogeny = parsePhyloXml text
+
+      (A.length <<< roots <$> phylogeny)
+        `shouldEqual`
+          (Right 1)
+
+      case phylogeny of
+        Right phylogeny' ->
+          (nodeName <$> (A.catMaybes (lookupNode phylogeny' <$> (roots phylogeny'))))
+            `shouldEqual`
+              [ ("A" /\ 0.0) ]
+        Left err -> fail $ reportError "" err
+
+    it "Parses a 4 node tree with a fork" do
+      let
+        text =
+          "<phyloxml><phylogeny rooted=\'true\'><clade name=\"A\"><clade><name>B</name></clade></clade></phylogeny></phyloxml>"
+      let phylogeny = parsePhyloXml text
+
+      (A.length <<< roots <$> phylogeny)
+        `shouldEqual`
+          (Right 1)
+
+      case phylogeny of
+        Right phylogeny' -> do
+          (nodeName <$> vertices phylogeny')
+            `shouldEqual`
+              [ ("A" /\ 0.0)
+              , ("B" /\ 0.0)
+              ]
+          edges phylogeny'
+            `shouldEqual`
+              [ (1 /\ 2) ]
+        Left err -> fail $ reportError "" err
+
     it "Parses the PhyloXML example" do
       text <- readTextFile UTF8 $ testDir </> "phyloxml_example2.xml"
 

test/js/parsing.ts

@@ -70,3 +70,39 @@ test("Throws when missing opening paren", (t) => {
 test("Throws when missing closing semicolon", (t) => {
   t.throws(() => parse("()"), { instanceOf: Error });
 });
+
+test("Can parse phyloxml", (t) => {
+  const text =
+    '<phyloxml><phylogeny rooted=\'true\'><clade name="A"><clade><name>B</name><clade name="C" /><clade name="D" /></clade></clade></phylogeny></phyloxml>';
+  const phy = parse(text);
+  t.deepEqual(vertices(phy), [
+    {
+      name: "A",
+      event: "Clade",
+      branchLength: 0,
+      ref: 1,
+      attributes: new Map(),
+    },
+    {
+      name: "B",
+      event: "Clade",
+      branchLength: 0,
+      ref: 2,
+      attributes: new Map(),
+    },
+    {
+      name: "C",
+      event: "Taxa",
+      branchLength: 0,
+      ref: 3,
+      attributes: new Map(),
+    },
+    {
+      name: "D",
+      event: "Taxa",
+      branchLength: 0,
+      ref: 4,
+      attributes: new Map(),
+    },
+  ]);
+});