More tests, workflows PR comment for feature test

.github/workflows/comment-feature-test.yml

@@ -0,0 +1,30 @@
+name: comment feature test results
+
+on:
+  workflow_run:
+    workflows: ["test data"]
+    types: [completed]
+
+permissions:
+  actions: read
+  pull-requests: write
+
+jobs:
+  comment:
+    runs-on: ubuntu-latest
+    if: github.event.workflow_run.event == 'pull_request'
+    steps:
+      - name: download feature test results
+        uses: actions/download-artifact@v4
+        with:
+          name: feature-test-results
+          run-id: ${{ github.event.workflow_run.id }}
+          github-token: ${{ secrets.GITHUB_TOKEN }}
+
+      - name: comment on PR
+        env:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+          GH_REPO: ${{ github.repository }}
+        run: |
+          PR_NUMBER=$(cat pr_number.txt)
+          gh pr comment "$PR_NUMBER" --body-file phoneme_feature_test_results.txt

.github/workflows/main.yml

@@ -5,17 +5,39 @@ on:
     branches: [ master ]
   pull_request:
     branches: [ master ]
-
 jobs:
   test-data:
     runs-on: ubuntu-latest
+    permissions:
+      contents: read
     steps:
       - uses: actions/checkout@v7
       - uses: prefix-dev/setup-pixi@v0.10.1
         with:
           pixi-version: v0.66.0
           activate-environment: "ci"
+      ## The following steps are temporary until we fix the phoneme feature test to pass in CI.
+      ## Once the phoneme feature test passes, update the below run tests command and remove filter and invert, and delete the following steps.
+      - name: run feature test (write to PR comment)
+        working-directory: tests
+        run: |
+          Rscript -e "testthat::test_file('test-phonemes.R', reporter = 'summary')" > phoneme_feature_test_results.txt 2>&1 || true
+      ## Fork PRs get a read-only GITHUB_TOKEN here, so this job can't comment
+      ## directly. comment-feature-test.yml (triggered via workflow_run) does it instead.
+      - name: save PR number
+        if: github.event_name == 'pull_request'
+        working-directory: tests
+        run: echo "${{ github.event.pull_request.number }}" > pr_number.txt
+      - name: upload feature test results
+        if: github.event_name == 'pull_request'
+        uses: actions/upload-artifact@v4
+        with:
+          name: feature-test-results
+          path: |
+            tests/phoneme_feature_test_results.txt
+            tests/pr_number.txt
+      ## Run the rest of the tests, excluding the phoneme feature test (which is run above).
       - name: run tests
         working-directory: tests
         run: |
-          Rscript -e "testthat::test_dir('.', stop_on_failure=TRUE)"
+            Rscript -e "testthat::test_dir('.', filter = 'phonemes', invert = TRUE, stop_on_failure = TRUE)"

pixi.toml

@@ -6,6 +6,7 @@ platforms = ["linux-64"]
 version = "0.1.0"
 
 [tasks]
+test = [{ task = "tests"}]
 
 [dependencies]
 r = "4.*"
@@ -16,6 +17,7 @@ r-stringi = ">=1.8.7,<2"
 
 [feature.agg.tasks]
 aggregate = { cmd = "Rscript aggregate-raw-data.R", cwd = "scripts" }
+add_features = { cmd = "Rscript add-features.R", cwd = "scripts" }
 
 [feature.ci.dependencies]
 r-dplyr = "1.1.1.*"
@@ -26,6 +28,9 @@ r-stringr = ">=1.5.1,<2"
 r-testthat = ">=3.2.1.1,<4"
 r-withr = ">=3.0.0,<4"
 
+[feature.ci.tasks]
+tests = { cmd = "Rscript -e \"testthat::test_dir('.', stop_on_failure=TRUE)\"", cwd = "tests" }
+
 [environments]
 agg = { features = ["agg"] }
 ci = { features = ["ci"] }

scripts/add-features.R

@@ -144,6 +144,7 @@ make_feat_vec_from_mat <- function(feat_mat) {
                                             zero=TRUE)
             ## look up the combined base glyphs in the special_feats table
             base_vec <- special_feats[special_feats$segment == base_pair, ]
+            stopifnot(nrow(base_vec) == 1)
             ## populate the feature vector from the special_feats table
             feat_vec[feature_cols] <- base_vec[feature_cols]
             # delete two bases

tests/test-cross-inventory-integrity.R

@@ -0,0 +1,100 @@
+#! /usr/bin/env Rscript
+
+## Tests for cross-inventory integrity. Checks that:
+##   1. No source accidentally split one language (Glottocode, LanguageName, SpecificDialect, BibtexKey) across two InventoryIDs
+##   2. Every BibtexKey in the mapping file resolves to a real entry in
+##      phoible-references.bib.
+##   3. Every InventoryID in the mapping files exists in the aggregated
+##      data, and vice versa.
+
+library(dplyr, warn.conflicts=FALSE)
+library(testthat, warn.conflicts=FALSE)
+
+## load PHOIBLE data
+phoible_data_file <- file.path("..", "data", "phoible.csv")
+phoible_col_types <- readr::cols(InventoryID="c", Marginal="l", .default="c")
+phoible <- readr::read_csv(phoible_data_file, col_types=phoible_col_types)
+
+bibtex_mapping_file <- file.path("..", "mappings", "InventoryID-Bibtex.csv")
+bibtex_mapping <- readr::read_csv(bibtex_mapping_file, col_types=readr::cols(.default="c"))
+
+# Join the phoible data with the mapping file to get a combined dataset for testing
+phoible_with_bibtex <- phoible %>%
+    left_join(bibtex_mapping, by="InventoryID", relationship="many-to-many")
+
+references_bib_file <- file.path("..", "mappings", "phoible-references.bib")
+
+context("Cross-inventory integrity")
+
+test_that("no source accidentally split one language across two InventoryIDs", {
+    ## Checks whether the same (Source, Glottocode, LanguageName, SpecificDialect, BibtexKey) tuple
+    ## appears in more than one InventoryID.
+    phoible_with_bibtex %>%
+        filter(!is.na(Glottocode)) %>%
+        distinct(InventoryID, Source, Glottocode, LanguageName, SpecificDialect, BibtexKey) %>%
+        group_by(Source, Glottocode, LanguageName, SpecificDialect, BibtexKey) %>%
+        filter(n_distinct(InventoryID) > 1) %>%
+        ungroup() ->
+        split_duplicates
+
+    expect(nrow(split_duplicates) == 0,
+           paste(c("SAME (Source, Glottocode, LanguageName, SpecificDialect, BibtexKey) APPEARS IN MULTIPLE INVENTORYIDS:",
+                   capture.output(print(split_duplicates, n=Inf))),
+                 sep="\n")
+           )
+    }
+)
+
+test_that("every BibtexKey resolves to a real bib entry", {
+    ## Check that every BibtexKey in the mapping file resolves to a real entry in phoible-references.bib.  
+
+    ## regex to match BibTeX keys in the .bib file  
+    citekey_re <- "(?m)^@\\w+\\s*\\{\\s*([^,]+?)\\s*,"
+
+    bib_keys <- stringr::str_match_all(
+        readr::read_file(references_bib_file), citekey_re
+    )[[1]][, 2]
+
+    mapping_keys <- bibtex_mapping %>% pull(BibtexKey) %>% unique()
+    missing_keys <- setdiff(mapping_keys, bib_keys)
+
+    # Exclude special case of InventoryID 201 (Arrente), which has "NO SOURCE GIVEN" as its BibtexKey
+    missing_keys <- setdiff(missing_keys, bibtex_mapping %>% filter(InventoryID == 201) %>% pull(BibtexKey))
+
+    ## report which InventoryID(s) cite each missing key
+    offending_rows <- bibtex_mapping %>%
+        filter(BibtexKey %in% missing_keys) %>%
+        arrange(BibtexKey, as.integer(InventoryID))
+    offending_summary <- offending_rows %>%
+        group_by(BibtexKey) %>%
+        summarise(InventoryIDs = paste(InventoryID, collapse=", "), .groups="drop")
+
+    expect(length(missing_keys) == 0,
+           paste(c(paste("BIBTEXKEYS WITH NO MATCHING ENTRY IN",
+                         basename(references_bib_file)),
+                   paste0(offending_summary$BibtexKey, " (InventoryID ",
+                          offending_summary$InventoryIDs, ")")),
+                 sep="\n")
+           )
+    }
+)
+
+test_that("mapping-file and aggregated-data InventoryIDs match in both directions", {
+    phoible_ids <- phoible %>% pull(InventoryID) %>% unique()
+    mapping_ids <- bibtex_mapping %>% pull(InventoryID) %>% as.integer() %>% unique()
+
+    only_in_mapping <- setdiff(mapping_ids, phoible_ids)
+    only_in_phoible <- setdiff(phoible_ids, mapping_ids)
+
+    expect(length(only_in_mapping) == 0,
+           paste(c("INVENTORYIDS IN InventoryID-Bibtex.csv BUT MISSING FROM",
+                   "AGGREGATED DATA:", paste(only_in_mapping, collapse=" ")),
+                 sep="\n")
+           )
+    expect(length(only_in_phoible) == 0,
+           paste(c("INVENTORYIDS IN AGGREGATED DATA BUT MISSING FROM",
+                   "InventoryID-Bibtex.csv:", paste(only_in_phoible, collapse=" ")),
+                 sep="\n")
+           )
+    }
+)

tests/test-inventory-metadata.R

@@ -141,6 +141,7 @@ test_that("glottocodes are valid", {
     glotto_url <- "https://github.com/glottolog/glottolog-cldf/blob/master/cldf/languages.csv?raw=true"
     glotto_table <- readr::read_csv(glotto_url, col_types=default_char_cols)
     glotto_valid <- pull(glotto_table, ID)
+    iso_valid_map <- pull(glotto_table, ISO639P3code)
 
     glotto_phoible <- pull(phoible, Glottocode)
     glotto_invalid <- setdiff(glotto_phoible, glotto_valid)
@@ -166,6 +167,39 @@ test_that("glottocodes are valid", {
                        collapse=" "),
                  sep="\n")
            )
+
+    ## Check that the ISO code in glottolog matches phoible's ISO code, for
+    ## every inventory with a known Glottocode (i.e. excluding Djindewal).
+    has_glottocode <- !is.na(phoible$Glottocode)
+
+    iso_from_glottolog <- iso_valid_map[match(phoible$Glottocode[has_glottocode], glotto_valid)]
+    iso_from_phoible <- phoible$ISO6393[has_glottocode]
+
+    ## Exclude known glottolog-ISO mismatches
+    known_mismatches <- rbind(
+        c(868,  "nepa1253", "kru"), # kxl (deprecated) merged into kru
+        c(1307, "krim1238", "bmf"), # krm (deprecated) merged into bmf
+        c(2750, "dira1238", "dif"), # dit (deprecated) merged into dif
+        c(2875, "band1337", "drl"), # bjd (deprecated) merged into drl
+        c(2256, "dark1243", "khk")  # drh (deprecated) merged into khk
+    )
+
+    overridable <- phoible$Glottocode[has_glottocode] %in% known_mismatches[, 2]
+    override <- setNames(known_mismatches[, 3], known_mismatches[, 2])
+    iso_from_glottolog[overridable] <- override[phoible$Glottocode[has_glottocode][overridable]]
+
+    mismatch_indices <- which(iso_from_glottolog != iso_from_phoible)
+
+    mismatch_ids <- phoible$InventoryID[has_glottocode][mismatch_indices]
+    mismatch_glottocodes <- phoible$Glottocode[has_glottocode][mismatch_indices]
+    mismatches <- unique(paste0(mismatch_ids, " (", mismatch_glottocodes, "): ", iso_from_phoible[mismatch_indices],
+                                " - ", iso_from_glottolog[mismatch_indices]))
+
+    expect(length(mismatches) == 0,
+           paste("MISMATCHED ISO CODES BETWEEN PHOIBLE AND GLOTTOLOG (InventoryID (glottocode)): phoible - glottolog):",
+                 paste0("- ", mismatches, collapse="\n"),
+                 sep="\n")
+           )
     }
 )
 

tests/test-regression-c-cedilla.R

@@ -0,0 +1,18 @@
+#! /usr/bin/env Rscript
+
+## Regression test for c-cedilla staying precomposed in order_ipa()
+## (aggregation-helper-functions.R), rather than decomposing it.
+
+library(stringi, warn.conflicts=FALSE)
+library(testthat, warn.conflicts=FALSE)
+
+source(file.path("..", "scripts", "aggregation-helper-functions.R"))
+
+context("Special-case exceptions regression")
+
+test_that("c-cedilla is unchanged by order_ipa()", {
+    ordered <- order_ipa("ç")
+    expect(identical(ordered, "ç"),
+           paste("Expected c-cedilla phoneme to be unchanged by order_ipa(), got",
+                 shQuote(ordered)))
+})

tests/test-regression-click-modifier.R

@@ -0,0 +1,57 @@
+#! /usr/bin/env Rscript
+
+## Regression test for the click/modifier typing in order_ipa() (aggregation-helper-functions.R). 
+## Clicks are deliberately typed "M", the same glyph-type code as real modifier letters
+## so they factor into feature-vector assignment the same way 
+## (see create_glyph_type_variables()/make_typestring()). 
+
+library(stringi, warn.conflicts=FALSE)
+library(testthat, warn.conflicts=FALSE)
+
+source(file.path("..", "scripts", "aggregation-helper-functions.R"))
+
+context("Click/modifier regression")
+
+test_that("a click is not deleted when followed by a modifier letter", {
+    ## dental click U+01C0 + aspirated U+02B0 both typed "M"
+    ## triggering the "MM" canonical-reordering block
+    result <- order_ipa("ǀʰ")
+    expect(stri_detect_fixed(result, "ǀ"),
+           paste("Click character was lost from", shQuote(result)))
+    expect(nchar(result) == 2,
+           paste("Expected a 2-character result, got", shQuote(result),
+                 "(", nchar(result), "characters)"))
+})
+
+test_that("a click is not deleted when preceding a modifier letter", {
+    ## same "MM" span, reversed input order
+    result <- order_ipa("ʰǀ")
+    expect(stri_detect_fixed(result, "ǀ"),
+           paste("Click character was lost from", shQuote(result)))
+    expect(nchar(result) == 2,
+           paste("Expected a 2-character result, got", shQuote(result),
+                 "(", nchar(result), "characters)"))
+})
+
+test_that("a click followed by a diacritic is not swapped the way a modifier would be", {
+    ## dental click + devoiced/ring-below diacritic (U+0325) - Typed "MD"
+    ## Should not be swapped to "DM" because the click is not a real modifier letter.
+    result <- order_ipa("ǀ̥")
+    expect(stri_detect_fixed(result, "ǀ"),
+           paste("Click character was lost from", shQuote(result)))
+    expect(identical(stri_sub(result, 1, 1), "ǀ"),
+           paste("Expected click to remain first, got", shQuote(result)))
+})
+
+test_that("a click preceding a real modifier+diacritic doesn't block their swap", {
+    ## typestring "MMD" with a click first, then a modifier letter, then a diacritic. 
+    ## The modifier+diacritic pair should still be swapped, but the click should remain first.
+    result <- order_ipa("ǀʰ̥")
+    expect(stri_detect_fixed(result, "ǀ"),
+           paste("Click character was lost from", shQuote(result)))
+    expect(identical(stri_sub(result, 1, 1), "ǀ"),
+           paste("Expected click to remain first, got", shQuote(result)))
+    expect(identical(result, "ǀ̥ʰ"),
+           paste("Expected the modifier+diacritic pair to still be swapped",
+                 "(click skip should not suppress it), got", shQuote(result)))
+})