R/qlsplineDS.R

In dsBase: 'DataSHIELD' Server Site Base Functions

#' 
#' @title Basis for a piecewise linear spline with meaningful coefficients
#' @description This function is based on the native R function \code{qlspline} from the
#' \code{lspline} package. This function computes the basis of piecewise-linear spline
#' such that, depending on the argument marginal, the coefficients can be interpreted as
#' (1) slopes of consecutive spline segments, or (2) slope change at consecutive knots.
#' @details If marginal is FALSE (default) the coefficients of the spline correspond to
#' slopes of the consecutive segments. If it is TRUE the first coefficient correspond to
#' the slope of the first segment. The consecutive coefficients correspond to the change
#' in slope as compared to the previous segment.
#' Function qlspline wraps lspline and calculates the knot positions to be at quantiles
#' of x. If q is a numerical scalar greater or equal to 2, the quantiles are computed at 
#' seq(0, 1, length.out = q + 1)[-c(1, q+1)], i.e. knots are at q-tiles of the distribution
#' of x. Alternatively, q can be a vector of values in [0; 1] specifying the quantile
#' probabilities directly (the vector is passed to argument probs of quantile).
#' @param x the name of the input numeric variable
#' @param q numeric, a single scalar greater or equal to 2 for a number of equal-frequency
#' intervals along x or a vector of numbers in (0; 1) specifying the quantiles explicitely.
#' @param na.rm logical, whether NA should be removed when calculating quantiles, passed
#' to na.rm of quantile. Default set to TRUE.
#' @param marginal logical, how to parametrize the spline, see Details
#' @param names character, vector of names for constructed variables
#' @return an object of class "lspline" and "matrix", which its name is specified by the
#' \code{newobj} argument (or its default name "qlspline.newobj"), is assigned on the serverside.
#' @author Demetris Avraam for DataSHIELD Development Team
#' @export
#'
qlsplineDS <- function(x = x, q = q, na.rm = TRUE, marginal = FALSE, names = NULL){
  
  # DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS
  thr <- dsBase::listDisclosureSettingsDS()
  nfilter.tab <- as.numeric(thr$nfilter.tab) 
  
  # this is a copy of the lspline function from lspline R package (version 1.0-0)
  # we use this copy just to avoid having one more package as a dependency of dsBase
  lspline_copy <- function (x, knots = NULL, marginal = FALSE, names = NULL) 
  {
    if (!is.null(names)) {
      .NotYetUsed("names")
    }
    n <- length(x)
    nvars <- length(knots) + 1
    namex <- deparse(substitute(x))
    knots <- sort(knots)
    if (marginal) {
      rval <- cbind(x, sapply(knots, function(k) ifelse((x - k) > 0, x - k, 0)))
    }
    else {
      rval <- matrix(0, nrow = n, ncol = nvars)
      rval[, 1] <- pmin(x, knots[1])
      rval[, nvars] <- pmax(x, knots[length(knots)]) - knots[length(knots)]
      if (nvars > 2) {
        for (i in seq(2, nvars - 1)) {
          rval[, i] <- pmax(pmin(x, knots[i]), knots[i - 1]) - knots[i - 1]
        }
      }
    }
    colnames(rval) <- seq(1, ncol(rval))
    structure(rval, knots = knots, marginal = marginal, class = c("lspline", "matrix"))
  }
  
  x <- eval(parse(text=x), envir = parent.frame())
  
  if (length(q) == 1 && q >= 2) {
    q <- seq(0, 1, length.out = q + 1)[-c(1, q + 1)]
  }else{
    stopifnot(all(q > 0 & q < 1))
  }
  k <- stats::quantile(x, probs = q, na.rm = na.rm)

  out <- lspline_copy(x = x, knots = k, marginal = marginal, names = names)
  
  for(i in 1:ncol(out)){
    if(length(unique(out[,i])) <= nfilter.tab){
      stop(paste0("One of the spline segments has less than ", nfilter.tab, 
                  " observations. Please redefine the knot positions"), call.=FALSE)
    }
  }
  
  return(out)
  
}
# ASSIGN FUNCTION
# qlsplineDS