First commit

.Rbuildignore

@@ -0,0 +1,4 @@
+^.*\.Rproj$
+^\.Rproj\.user$
+^README\.Rmd$
+^data-raw$

.gitignore

@@ -0,0 +1,4 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata

DESCRIPTION

@@ -0,0 +1,29 @@
+Package: growthscreener
+Title: Finding Children with Unusual Growth Patterns
+Version: 1.0.0
+Authors@R: 
+    c(person(given = "Paula",
+           family = "van Dommelen",
+           role = c("aut", "cre"),
+           email = "paula.vandommelen@tno.nl"),
+       person(given = "Stef",
+           family = "van Buuren",
+           role = c("aut"),
+           email = "stef.vanbuuren@tno.nl"))
+Description: Unusual child growth may be a sign of an underlying 
+    disease or condition. This package implements functions that 
+    evaluate the growth pattern of a child relative to Dutch 
+    guidelines.
+Depends: 
+    R (>= 2.10)
+Imports: 
+    AGD (>= 0.41.0)
+Remotes: 
+    stefvanbuuren/AGD
+License: AGPL-3 + file LICENSE
+Encoding: UTF-8
+LazyData: true
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 6.1.1
+Suggests: 
+    testthat (>= 2.1.0)

LICENSE

@@ -0,0 +1,31 @@
+    growthscreener: Finding Children with Unusual Growth Patterns
+    Copyright (C) 2019 Paula van Dommelen, Stef van Buuren
+
+    Source: <https://github.com/stefvanbuuren/growthscreener>
+    Contact: paula.vandommelen at tno.nl
+
+    This program is free software: you can redistribute it and/or modify
+    it under the terms of the GNU Affero General Public License as
+    published by the Free Software Foundation, either version 3 of the
+    License, or (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU Affero General Public License for more details.
+
+    You should have received a copy of the GNU Affero General Public License
+    along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+    If your software can interact with users remotely through a computer
+    network, you should also make sure that it provides a way for users
+    to get its source. For example, if your program is a web application,
+    its interface could display a "Source" link that leads users to an
+    archive of the code. There are many ways you could offer source,
+    and different solutions will be better for different programs; see
+    section 13 for the specific requirements.
+
+    You should also get your employer (if you work as a programmer) or
+    school, if any, to sign a "copyright disclaimer" for the program,
+    if necessary. For more information on this, and how to apply and
+    follow the GNU AGPL, see <https://www.gnu.org/licenses/>.

NAMESPACE

@@ -0,0 +1,9 @@
+# Generated by roxygen2: do not edit by hand
+
+export(calculate_advice_hgt)
+export(calculate_birth_z)
+export(calculate_helpers_hgt)
+export(calculate_th)
+export(fold)
+export(msg)
+importFrom(AGD,y2z)

R/calculate_advice_hgt.R

@@ -0,0 +1,148 @@
+#' Referral advice for body height
+#'
+#' This function traverses the decision tree of the
+#' "JGZ-Richtlijn Lengtegroei 2019".
+#'
+#' The decision tree assesses both single and paired measurements.
+#' The last observations (\code{y1}) is generally taken as the
+#' last measurement, whereas \code{y0} can be one of the previous
+#' measurements. For more than two measurements, there are many
+#' pairs possible, and these pairs need not be consecutive.
+#' The \code{y0} measurement needs to be defined by the user,
+#' and is informally taken as an earlier measurement that maximumizes
+#' the referal probability. On the other hand, defining pairs that are
+#' remote in ages (e.g. period between 1 month and 14 years) is probably
+#' not that useful. In practice, we may be interested in setting the
+#' maximum period to, say, five years.
+#' @param sex   Character, either \code{"M"} (male) or \code{"F"} (female)
+#' @param dob   Date of birth (class Date)
+#' @param bw    Birth weight (grammes)
+#' @param bl    Birth length (cm)
+#' @param ga    Gestational age, completed weeks (Integer or character)
+#' @param etn   Etnicity, one of \code{"N"} (dutch), \code{"T"} (turkish),
+#'              \code{"M"} (moroccan) or \code{"H"} (hindustani).
+#' @param hgtf  Height of father (cm)
+#' @param hgtm  Height of mother (cm)
+#' @param dom1  Date of last measurement (Date)
+#' @param y1    Height at last measurement (cm)
+#' @param dom0  Date of previous measurement (Date)
+#' @param y0    Height at previous measurement (cm)
+#' @param d     Optional, list of derived variables, obtained by
+#'              \code{calculate_derived_variables()}
+#' @return \code{calculate_advice_hgt} returns an integer, the \code{msgcode}
+#' @author Paula van Dommelen, Stef van Buuren, 2019
+#' @rdname advice_hgt
+#' @examples
+#' msg(calculate_advice_hgt())
+#' msgcode <- calculate_advice_hgt(sex = "M", etn = "N",
+#'                                 dob = as.Date("2018-07-31"),
+#'                                 dom1 = as.Date("2018-12-12"), y1 = 64)
+#' msg(msgcode)
+#' @export
+calculate_advice_hgt <- function(sex = NA_character_, dob = as.Date(NA),
+                                 bw = NA, bl = NA, ga = NA,
+                                 etn = NA_character_, hgtf = NA, hgtm = NA,
+                                 dom1 = as.Date(NA), y1 = NA,
+                                 dom0 = as.Date(NA), y0 = NA,
+                                 d = NULL) {
+
+  if (is.null(d))
+    d <- calculate_helpers_hgt(sex, dob, bw, bl, ga, etn,
+                               hgtf, hgtm, dom1, y1, dom0, y0)
+  bw_z <- d$bw_z
+  bl_z <- d$bl_z
+  th_z <- d$th_z
+  age1 <- d$age1
+  age0 <- d$age0
+  z1   <- d$z1
+  z0   <- d$z0
+
+  # start the sieve
+
+  # return early if data are insufficient
+  # if (is.na(sex)) return(19)
+  if (!sex %in% c("M", "F")) return(19)
+  if (is.na(dob)) return(16)
+  if (is.na(dom1)) return(15)
+  if (is.na(y1)) return(ifelse(age1 < 18.0, 18, 21))
+  if (!etn %in% c("N", "T", "M", "H")) return(20)
+
+  # outside age range
+  if (age1 >= 18.0) return(21)
+  if (age1 < 0.0833) return(22)
+
+  # check single measurement
+  if (age1 < 3.0) {
+    # short
+    if (z1 < -2.5 & is.na(bw)) return(13)
+    if (z1 < -3.0 & bw >= 2500) return(45)
+
+    # tall
+    if (z1 > 3.0) return(48)
+    if (z1 > 2.5 & is.na(z0)) return(11)
+    if (z1 > 1.0) return(77)
+  }
+
+  if (age1 >= 3.0 & age1 < 10.0) {
+
+    # short
+    if (z1 < -2.5) return(44)
+    if (z1 < -2.0 & !is.na(bw_z)) if (bw_z < -2.0) return(42)
+    if (z1 < -2.0 & !is.na(bl_z)) if (bl_z < -2.0) return(41)
+    if (!is.na(th_z)) {
+      if (z1 <  -2.0 & (z1 - th_z) < -1.6) return(43)
+      if (z1 >= -2.0 & z1 < -1.0 & (z1 - th_z) < -2.0) return(53)
+    }
+    if (z1 < -2.0 & is.na(bw)) return(13)
+    if (z1 < -2.0 & is.na(bl)) return(12)
+    if (z1 < -1.0 & is.na(th_z)) return(14)
+
+    # tall
+    if (z1 > 2.5) return(47)
+    if (!is.na(th_z)) if (z1 > 2.0 & (z1 - th_z) > 2.0) return(46)
+    if (z1 > 2.0 & is.na(th_z)) return(82)
+    if (z1 > 1.0 &
+        ((age1 < 8.0 & sex == "F") | (age1 < 9.0 & sex == "M"))) return(79)
+    if (z1 > 1.0) return(81)
+
+    if (is.na(z0)) return(11)
+  }
+
+  if (age1 >= 10.0 & age1 < 18.0) {
+    # short
+    if (z1 < -2.5) return(44)
+
+    # tall
+    if (z1 > 2.5) return(47)
+    if (z1 > 2.0 & sex == "F" & y1 >= 170) return(71)
+    if (z1 > 2.0 & sex == "M" & y1 >= 185) return(72)
+    if (z1 > 2.0) return(73)
+    if (sex == "F" & y1 >= 170.0) return(74)
+    if (sex == "M" & y1 >= 185.0) return(75)
+  }
+
+  # check for gain z1 - z0
+  if (!is.na(z0)) {
+    if (age1 < 3.0) {
+      # short
+      if (z1 < -2.5 & z0 < -2.5 & is.na(bw)) return(13)
+      if (z1 < -2.5 & z0 < -2.5 & bw >= 2500) return(49)
+
+      # tall
+      if (z1 > 2.5 & z0 > 2.5) return(50)
+    }
+
+    if (age1 >= 3.0 & age1 < 10.0) {
+      # short
+      if ((z1 - z0) < -2.0) return(55)
+      if (!is.na(th_z))
+        if (z1 >= -2.0 & (z1 - z0) < -1.0 & (z1 - th_z) < -1.0) return(76)
+
+      # tall
+      if ((z1 - z0) > 2.0) return(54)
+    }
+  }
+
+  # signal everthing is OK
+  return(31)
+}

R/calculate_birth_z.R

@@ -0,0 +1,43 @@
+#' Calculate birth weight SDS relative to Dutch references
+#'
+#' @param y     Birth weight (grammes) or birth length (cm).
+#'              May be a vector. Converted to numeric.
+#' @param sex   Character, either \code{"M"} (male) or \code{"F"} (female)
+#' @param ga    Gestational age, completed week (Integer or character)
+#' @param yname Either \code{"wgt"} (for birth weight) or \code{"hgt"}
+#'              (for birth length)
+#' @param dec   Number of decimals for rounding
+#' @return      Numeric vector of \code{length(bw)} elements with
+#'              standard deviation scores relative to Dutch birth
+#'              weight references
+#' @author      Stef van Buuren, 2019
+#' @examples
+#' calculate_birth_z(c(2500, 3000), sex = "M", ga = 36)
+#' @export
+calculate_birth_z <- function(y, sex, ga, yname = "wgt",
+                              dec = 3) {
+  # convert inputs
+  y <- suppressWarnings(as.numeric(y))
+  sex <- as.character(sex[1L])
+  ga <- suppressWarnings(as.integer(ga[1L]))
+  if (is.na(ga)) return(rep(NA, length(y)))
+
+  # find reference
+  ref <- NULL
+  if (yname == "wgt") {
+    ref <- growthscreener::ref.nl5defSGAgewicht
+    y <- y / 1000
+  }
+  if (yname == "hgt") ref <- growthscreener::ref.nl5defSGAlengte
+  if (is.null(ref)) return(rep(NA, length(y)))
+
+  # find proper row
+  idx <- ref$sex == sex & ref$ga == ga
+  if (any(is.na(idx))) return(rep(NA, length(y)))
+  if (!any(idx)) return(rep(NA, length(y)))
+
+  # calculate
+  z <- round(((y / ref$M[idx])^ref$L[idx] - 1) / (ref$L[idx] * ref$S[idx]), dec)
+  z[is.nan(z)] <- NA
+  z
+}

R/calculate_helpers_hgt.R

@@ -0,0 +1,39 @@
+#' @details \code{calculate_helpers_hgt()} provides an optional
+#' pre-calculation for \code{calculate_advice_hgt()}. The user may
+#' wish to divide up calculations into two steps if intermediate
+#' results are needed.
+#' @rdname advice_hgt
+#' @inheritParams calculate_advice_hgt
+#' @return \code{calculate_helpers_hgt()} returns a \code{list} with
+#' the following elements:
+#' \describe{
+#' \item{\code{bw_z}}{Birth weight SDS}
+#' \item{\code{bl_z}}{Birth length SDS}
+#' \item{\code{th}}{Target height (cm)}
+#' \item{\code{th_z}}{Target height SDS}
+#' \item{\code{age1}}{Age at last measurement}
+#' \item{\code{age0}}{Age at previous measurement}
+#' \item{\code{z1}}{Height SDS at \code{age1}}
+#' \item{\code{z0}}{Height SDS at \code{age0}}
+#' }
+#' @export
+calculate_helpers_hgt <- function(sex = NA_character_, dob = as.Date(NA),
+                                  bw = NA, bl = NA, ga = NA,
+                                  etn = NA_character_, hgtf = NA, hgtm = NA,
+                                  dom1 = as.Date(NA), y1 = NA,
+                                  dom0 = as.Date(NA), y0 = NA) {
+  bw_z <- calculate_birth_z(bw, sex, ga, yname = "wgt")
+  bl_z <- calculate_birth_z(bl, sex, ga, yname = "hgt")
+  thl  <- calculate_th(hgtf, hgtm, sex = sex, etn = etn)
+  th   <- thl[1L]
+  th_z <- thl[2L]
+  age1 <- as.integer(dom1 - dob)/365.25
+  age0 <- as.integer(dom0 - dob)/365.25
+  z1 <- y2z(y = y1, x = age1, sex = sex, sub = etn,
+            ref = growthscreener::nl5.hgt)
+  z0 <- y2z(y = y0, x = age0, sex = sex, sub = etn,
+            ref = growthscreener::nl5.hgt)
+
+  list(bw_z = bw_z, bl_z = bl_z, th = th, th_z = th_z,
+       age1 = age1, age0 = age0, z1 = z1, z0 = z0)
+}

R/calculate_th.R

@@ -0,0 +1,60 @@
+#' Calculate target height SDS
+#'
+#' @param hgtf  Length of biological father (cm)
+#' @param hgtm  Length of biological mother (cm)
+#' @param sex   Character, either \code{"M"} (male) or \code{"F"} (female)
+#' @param etn   Etnicity, one of \code{"N"} (dutch), \code{"T"} (turkish),
+#'              \code{"M"} (moroccan) or \code{"H"} (hindustani).
+#' @param dec   Integer vector, length 2, indicating rounding for
+#'              th and th_z, respectively
+#' @return      Numeric, length 2: target height (cm) and target height
+#'              standard deviation score (z), relative to populations
+#'              living in The Netherlands
+#' @author      Stef van Buuren, 2019
+#' @examples
+#' calculate_th(180, 170, "M", "N")
+#' @export
+calculate_th <- function(hgtf, hgtm,
+                         sex = NULL, etn = NULL,
+                         dec = c(1L, 3L)) {
+
+  # don't calculate if we're missing proper sex or etn
+  if (is.null(sex) | is.null(etn)) return(c(NA, NA))
+  if (!sex %in% c("M", "F")) return(c(NA, NA))
+  if (!etn %in% c("N", "T", "M", "H")) return(c(NA, NA))
+
+  if (sex == "M") {
+    th <- switch(EXPR = etn,
+                 "N" = 44.5 + 0.376 * hgtf + 0.411 * hgtm,
+                 "T" = 29.6 + 0.441 * hgtf + 0.465 * hgtm,
+                 "M" = 22.4 + 0.439 * hgtf + 0.508 * hgtm,
+                 "H" = 43.6 + 0.366 * hgtf + 0.431 * hgtm,
+                 NA)
+    th_z <- switch(EXPR = etn,
+                   "N" = (th - 183.8) / 7.1,
+                   "T" = (th - 176.8) / 6.8,
+                   "M" = (th - 177.2) / 7.7,
+                   "H" = (th - 174.3) / 7.0,
+                   NA)
+  }
+
+  if (sex == "F") {
+    th <- switch(EXPR = etn,
+                 "N" = 47.1 + 0.334 * hgtf + 0.364 * hgtm,
+                 "T" = 32.8 + 0.389 * hgtf + 0.410 * hgtm,
+                 "M" = 32.1 + 0.370 * hgtf + 0.429 * hgtm,
+                 "H" = 49.4 + 0.308 * hgtf + 0.364 * hgtm,
+                 NA)
+    th_z <- switch(EXPR = etn,
+                   "N" = (th - 170.7) / 6.3,
+                   "T" = (th - 162.6) / 6.0,
+                   "M" = (th - 162.8) / 6.5,
+                   "H" = (th - 159.6) / 5.9,
+                   NA)
+  }
+
+  th <- round(th, dec[1])
+  th_z <- round(th_z, dec[2])
+
+  c(th, th_z)
+}

R/datasets.R

@@ -0,0 +1,15 @@
+#' Table of Dutch birth weight references
+#' @name datasets
+"ref.nl5defSGAgewicht"
+
+#' Table of Dutch birth length references
+#' @rdname datasets
+"ref.nl5defSGAlengte"
+
+#' Table of Dutch nl5 references
+#' @rdname datasets
+"nl5.hgt"
+
+#' Table of return message and return code
+#' @rdname datasets
+"messages_hgt"