version 0.6.1

DESCRIPTION

@@ -0,0 +1,28 @@
+Package: KLINK
+Title: Kinship Analysis with Linked Markers
+Version: 0.6.1
+Authors@R: 
+    person("Magnus Dehli", "Vigeland", , "m.d.vigeland@medisin.uio.no", role = c("aut", "cre"))
+Description: A 'shiny' application for forensic kinship testing, based on
+    the 'pedsuite' R packages. 'KLINK' is closely aligned with the (non-R)
+    software 'Familias' and 'FamLink', but offers several unique features,
+    including visualisations and automated report generation. The
+    calculation of likelihood ratios supports pairs of linked markers, and
+    all common mutation models.
+License: GPL (>= 3)
+URL: https://github.com/magnusdv/KLINK
+BugReports: https://github.com/magnusdv/KLINK/issues
+Depends: R (>= 4.1)
+Imports: forrel (>= 1.5.3), gt (>= 0.9.0), openxlsx, pedmut (>= 0.6.0),
+        pedprobr (>= 0.8.0), pedtools (>= 2.3.1), pkgload, shiny (>=
+        1.7.4), shinydashboard, utils, verbalisr
+Encoding: UTF-8
+Language: en-GB
+LazyData: true
+RoxygenNote: 7.2.3
+NeedsCompilation: no
+Packaged: 2023-08-29 18:55:38 UTC; magnusdv
+Author: Magnus Dehli Vigeland [aut, cre]
+Maintainer: Magnus Dehli Vigeland <m.d.vigeland@medisin.uio.no>
+Repository: CRAN
+Date/Publication: 2023-08-30 15:50:08 UTC

MD5

@@ -0,0 +1,22 @@
+e8336e02ee096107e126242083d23fd7 *DESCRIPTION
+6aab6fb3adaab3a0e3e31e4ac3f7fc32 *NAMESPACE
+9ce4ccc49456063b961597c67c082b7e *NEWS.md
+95ddc64656607b5ce629ba41370fa956 *R/KLINK-package.R
+573c166330c824bc4bd8717b227d0bd2 *R/data.R
+ca7f32b9dea511afb1b222b71caf9d7f *R/karyo.R
+f2c422c64d244aaa3e808ebe2bbc01e0 *R/linkedLR.R
+00de0e301b353dd38711b945e60703e8 *R/loadFamFile.R
+c0a380c479bf947092cd80b2b0f90aca *R/lumping.R
+de37c8fa4ad045e82e0ea3c775089599 *R/markerSummary.R
+3e2bb3055512cf6b37728e46f3a33c52 *R/plotPed.R
+c42aa511a6d6be1b96e840c3759b1457 *R/prettyTable.R
+008c5dbc9667d2df930b8291f1a93463 *R/runKLINK.R
+1461e007b0aea83e99f588b6ce6ac41b *R/utils.R
+d1557d1b1f8eb175425ed014abc4b541 *R/writeResult.R
+9e85584d05e70582264591e361708aae *README.md
+df96c66f43a4fd12699a81b16f8db9a1 *data/LINKAGEMAP.rda
+4457ee18ae36d06765bc11a9d849cb85 *inst/extdata/halfsib-test.fam
+7292f31ac558c5cd9bbf13004dcc4c62 *man/KLINK-package.Rd
+8fba5f586d2bf351f01b15133c25dcb9 *man/LINKAGEMAP.Rd
+881028ce6a09bf7e231540991c5620bb *man/linkedLR.Rd
+a480e01e738deec0ea9f9eb81cb5492d *man/runKLINK.Rd

NAMESPACE

@@ -0,0 +1,16 @@
+# Generated by roxygen2: do not edit by hand
+
+export(linkedLR)
+export(runKLINK)
+import(gt)
+import(openxlsx)
+import(pedtools)
+import(shiny, except = c(singleton, is.singleton))
+import(shinydashboard)
+importFrom(graphics,legend)
+importFrom(graphics,par)
+importFrom(graphics,plot.new)
+importFrom(graphics,points)
+importFrom(graphics,rect)
+importFrom(graphics,text.default)
+importFrom(utils,packageDescription)

NEWS.md

@@ -0,0 +1,28 @@
+# KLINK 0.6.1
+
+* First CRAN release.
+
+
+# KLINK 0.5.0
+
+* Add karyogram showing marker positions.
+
+* Add sheets "Unlinked" and "Linked only" in excel output.
+
+* Tweaked button placements.
+
+
+# KLINK 0.4.1
+
+* New button letting the user choose fallback mutation model (applied when a model specified in the input file fails for whatever reason).
+
+* Fixed a couple of minor bugs
+
+
+# KLINK 0.4.0
+
+* Added a `NEWS.md` file to track changes to the package.
+
+* **pedtools** version 2.2.0 is now required.
+
+* If the pedigrees prohibit arbitrary lumping, all complex mutation models are replaced with a simpler model. A notification to this effect is added when loading the file. This behaviour is currently triggered if either pedigree has an untyped nonfounder.   

R/KLINK-package.R

@@ -0,0 +1,17 @@
+#' @keywords internal
+"_PACKAGE"
+
+## usethis namespace: start
+#' @rawNamespace import(shiny, except = c(singleton, is.singleton))
+#' @import shinydashboard
+#' @import gt
+#' @import openxlsx
+#' @import pedtools
+## usethis namespace: end
+NULL
+
+
+# Hack to avoid CRAN note. (load_all is only used in app.R which is in Rbuildignore.)
+ignore_unused_imports = function() {
+  pkgload::load_all
+}

R/data.R

@@ -0,0 +1,7 @@
+#' Built-in linkage map
+#'
+#' A genetic map including 9 pairs of linked STR markers
+#'
+#' @format A data frame with 18 rows and 5 columns.
+#'
+"LINKAGEMAP"

R/karyo.R

@@ -0,0 +1,36 @@
+#' @importFrom graphics legend par plot.new points rect text.default
+karyogram = function(markerdata, cols = KARYOPALETTE, bgcol = "gray92") {
+
+  h = 0.7
+  plot.new()
+
+  oldpar = par(no.readonly = TRUE)
+  on.exit(par(oldpar))
+
+  par(mar = c(1,2,1,1), usr = c(0, max(CHROM.MB), 22+h, 1), xpd = TRUE)
+
+  rect(xleft = 0, ybottom = 1:22, xright = CHROM.MB, ytop = 1:22 + h, col = bgcol)
+  text.default(0, 1:22 + h/2, labels = 1:22, pos = 2)
+
+  # Positions
+  chr = markerdata$Chrom
+  x = markerdata$PosCM * CHROM.MB[chr]/CHROM.CM[chr]
+  y = chr + h/2
+  points(x, y, bg = cols[markerdata$Pair], pch = 21, cex = 2.2)
+
+  legend(max(CHROM.MB), 13+h/2, xjust = 1, y.intersp = 0, legend = 1:9,
+         pch = 21, pt.cex = 2.2, pt.bg = cols[1:9], bty = "n")
+}
+
+CHROM.MB = c(247.2, 242.9, 199.5, 191.3, 180.9, 170.9, 158.8, 146.3, 140.3,
+             135.4, 134.4, 132.3, 114.1, 106.4, 100.3,  88.8,  78.8, 76.1,
+             63.8,  62.4,  46.9,  49.7)
+
+CHROM.CM = c(267.8, 251.7, 218.3, 202.9, 197.1, 186.0, 178.4, 161.5, 157.3,
+             169.3, 154.5, 165.5, 127.2, 116.0, 117.3, 126.6, 129.5, 116.5,
+             106.4, 107.8,  62.9,  70.8)
+
+KARYOPALETTE = c("#FD3216FF", "#00FE35FF", "#6A76FCFF", "#FED4C4FF", "#FE00CEFF", "#0DF9FFFF",
+                 "#F6F926FF", "#FF9616FF", "#479B55FF", "#EEA6FBFF", "#DC587DFF", "#D626FFFF",
+                 "#6E899CFF", "#00B5F7FF", "#B68E00FF", "#C9FBE5FF", "#FF0092FF", "#22FFA7FF",
+                 "#E3EE9EFF", "#86CE00FF", "#BC7196FF", "#7E7DCDFF", "#FC6955FF", "#E48F72FF")

R/linkedLR.R

@@ -0,0 +1,114 @@
+#' LR with pairwise linked markers
+#'
+#' This function does the main LR calculations of the KLINK app.
+#'
+#' @param pedigrees A list of two pedigrees.
+#' @param linkageMap A data frame with columns including `Pair`, `Marker`,
+#'   `Chrom`, `PosCM`
+#' @param markerData A data frame, normally extracted automatically from
+#'   `pedigrees`.
+#' @param mapfun Name of the map function to be used; either "Haldane" or
+#'   "Kosambi" (default)
+#'
+#' @return A data frame with detailed LR results.
+#'
+#' @examples
+#' library(forrel)
+#'
+#' ped1 = nuclearPed(fa = "AF", child = "CH") |>
+#'   profileSim(markers = NorwegianFrequencies)
+#'
+#' ped2 = singletons(c("AF", "CH")) |>
+#'   transferMarkers(from = ped1, to = _)
+#'
+#' pedigrees = list(ped1, ped2)
+#'
+#' linkedLR(pedigrees, LINKAGEMAP)
+#'
+#' @export
+linkedLR = function(pedigrees, linkageMap, markerData = NULL, mapfun = "Kosambi") {
+
+  if(is.null(markerData))
+    markerData = markerSummary(pedigrees, linkageMap)
+
+  MAPFUN = switch(mapfun, Haldane = pedprobr::haldane, Kosambi = pedprobr::kosambi)
+
+  # Initialise table: Pair, Marker, Geno
+  res = markerData[c(1, 2, grep("Person", names(markerData), fixed = TRUE))]
+  nr = nrow(res)
+
+  # Add cM positions
+  res$PosCM = linkageMap$PosCM[match(res$Marker, linkageMap$Marker)]
+
+  # Replace missing pairs with dummy 1001, 1002, ... (otherwise lost in split)
+  if(any(NApair <- is.na(res$Pair)))
+    res$Pair[NApair] = 1000 + seq_along(which(NApair))
+
+  # Group size (1 or 2)
+  res$Gsize = stats::ave(1:nr, res$Pair, FUN = function(a) rep(length(a), length(a)))
+
+  # Put (intact) pairs on top
+  res = res[order(-res$Gsize, res$Pair, res$PosCM), , drop = FALSE]
+
+  # Index within each group (do after ordering!)
+  res$Gindex = stats::ave(1:nr, res$Pair, FUN = seq_along)
+
+  # Special lumping
+  if(specialLumpability(pedigrees))
+    pedigrees = lapply(pedigrees, lumpAllSpecial)
+
+  # Single-point LR
+  lr1 = forrel::kinshipLR(pedigrees, markers = res$Marker)
+  res$LRsingle = lr1$LRperMarker[,1]
+
+  # No-mutation versions
+  pedsNomut = lapply(pedigrees, function(x) setMutmod(x, model = NULL))
+  LRnomut = forrel::kinshipLR(pedsNomut, markers = res$Marker)$LRperMarker[,1]
+
+  # Split linkage groups
+  pairs = split(res, res$Pair)
+
+  res$LRnolink = NA_real_
+  res$LRlinked = NA_real_
+  res$LRnomut  = NA_real_
+
+  for(pp in pairs) {
+    m = pp$Marker
+    idx1 = match(m[1], res$Marker)
+
+    if(nrow(pp) == 2) {
+      res$LRnolink[idx1] = prod(pp$LRsingle)
+      res$LRlinked[idx1] = .linkedLR(pedigrees, m, cmpos = pp$PosCM, mapfun = MAPFUN)
+      res$LRnomut[idx1]  = .linkedLR(pedsNomut, m, cmpos = pp$PosCM, mapfun = MAPFUN)
+    }
+    else {
+      res$LRnolink[idx1] = res$LRlinked[idx1] = pp$LRsingle
+      res$LRnomut[idx1] = LRnomut[[m]]
+    }
+  }
+
+  # Repair "Pair" column
+  res$Pair = ifelse(res$Gsize > 1, paste("Pair", res$Pair), "Unpaired")
+
+  res
+}
+
+
+.linkedLR = function(peds, markerpair, cmpos, mapfun, disableMut = FALSE) {
+  if(length(markerpair) < 2)
+    return(NA_real_)
+
+  rho = mapfun(diff(cmpos))
+
+  H1 = pedtools::selectMarkers(peds[[1]], markerpair)
+  H2 = pedtools::selectMarkers(peds[[2]], markerpair)
+
+  if(disableMut) {
+    H1 = H1 |> setMutmod(model = NULL)
+    H2 = H2 |> setMutmod(model = NULL)
+  }
+
+  numer = pedprobr::likelihood2(H1, marker1 = 1, marker2 = 2, rho = rho)
+  denom = pedprobr::likelihood2(H2, marker1 = 1, marker2 = 2, rho = rho)
+  numer/denom
+}

R/loadFamFile.R

@@ -0,0 +1,60 @@
+
+loadFamFile = function(path, fallbackModel = "equal") {
+  x = forrel::readFam(path, useDVI = FALSE, verbose = FALSE, prefixAdded = ":missing:",
+                      fallbackModel = fallbackModel)
+
+  if(!length(x) || (!is.ped(x[[1]]) && !is.pedList(x[[1]])))
+    stop("No pedigrees found in the Familias file.", call. = FALSE)
+
+  if(all(sapply(x, pedtools::is.singleton)))
+    stop("This Familias file contains only singletons", call. = FALSE)
+
+  # Ensure each pedigree is an unnamed list
+  x = lapply(x, function(xx) {
+    if(pedtools::is.ped(xx))
+      list(xx)
+    else if(pedtools::is.pedList(xx))
+      unname(xx)
+    else
+      stop("Unexpected content detected in the Familias file.")
+  })
+
+  if(length(x) == 1)
+    stop("Only one pedigree found in the Familias file.", call. = FALSE)
+
+  if(length(x) > 2) {
+    warning("This familias file contains more than two pedigrees; only the first two are used", call. = FALSE)
+    x = x[1:2]
+  }
+
+  if(!specialLumpability(x)) {
+    alwLumpable = vapply(1:nMarkers(x[[1]]), FUN.VALUE = FALSE, function(i)
+      is.null(mut <- mutmod(x[[1]], i)) || pedmut::alwaysLumpable(mut))
+    if(!all(alwLumpable)) {
+      x = lapply(x, function(ped)
+        setMutmod(ped, markers = !alwLumpable, model = fallbackModel, update = TRUE))
+      msg = sprintf("Pedigree prohibits lumping of complex mutation models; changed these to '%s'",
+                    fallbackModel)
+      warning(msg, call. = FALSE)
+    }
+  }
+
+  if(is.null(names(x)))
+    names(x) = c("Ped 1", "Ped 2")
+
+  x
+}
+
+
+removeEmpty = function(x) {
+  if(is.null(x))
+    return(NULL)
+  for(pedname in names(x)) {
+    ped = x[[pedname]]
+    empty = vapply(ped, function(comp) !any(unlist(comp$MARKERS)), FALSE)
+    if(all(empty))
+      stop(sprintf("Pedigree '%s' has no typed members", pedname))
+    x[[pedname]] = ped[!empty]
+  }
+  x
+}