R/extract.R

In andrie/surveydata: Tools to Work with Survey Data

# Subsetting code for surveydata objects

#
#  surveydata/R/extract.R by Andrie de Vries  Copyright (C) 2011-2017
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 or 3 of the License
#  (at your option).
#
#  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 General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/
#


#' Extract or replace subsets of surveydata, ensuring that the varlabels stay synchronized.
#'
#' The `surveydata` package makes it easy to extract specific questions from a surveydata object. Because survey data typically has question names like "Q1_a", "Q1_b", "Q1_c" the extract method for a `surveydata` object makes it easy to extract all columns by simply specifying "Q1" as the argument to the column index.
#'
#' Extraction is similar to data frames, with three important exceptions:
#' * The column argument `j` is evaluated using [which.q()] and will return all columns where the column names match the [pattern()].
#' * The `drop` argument is `FALSE`. Thus the result will always be a surveydata object, even if only a single column is returned.
#' * All extraction methods retain the `pattern` and `varlabels` arguments.
#'
#' @name Extract
#' @param i row index
#' @param j column index
#' @param drop logical. Passed to `[.data.frame`. Note that the default is `FALSE`.
#' @export
#' @keywords internal
#' @aliases [ "[.surveydata"
#' @method [ surveydata
#' @example /inst/examples/example-extract.R
`[.surveydata` <- function(x, i, j, drop = FALSE) {
  name <- NULL
  has.drop <- !missing(drop)
  Narg <- nargs() - (has.drop) - 1
  has.i <- !missing(i)
  has.j <- !missing(j)

  if (!has.i & !has.j) return(x)

  if (Narg >= 1L & has.j) {
    name <- j
    if (is.character(j)) {
      w <- which.q(x, j)
      if (length(w) != 0) {
        j <- name <- w
      }
    } else {
      name <- j
    }
  } else { 
    # !has.j
    name <- seq_along(x)
  }

  if (Narg == 1L & has.i) {
    drop <- NULL
    name <- i
    if (is.character(i)) {
      w <- which.q(x, i)
      if (length(w) != 0) {
        i <- name <- w
      } else {
        name <- i
      }
    } else {
      name <- i
    }
  }

  if (is.null(drop)) {
    ret <- NextMethod("[<-")
  } else {
    ret <- NextMethod("[<-", drop = drop)
  }

  if (is.data.frame(ret)) {
    varlabels(ret) <- varlabels(x)[name]
    as.surveydata(ret, ptn = pattern(x), renameVarlabels = FALSE)
  } else {
    ret
  }
}



#' @rdname Extract
#' @method [<- surveydata
#' @usage \method{[}{surveydata}(x, i, j) <- value
#' @export
#' @keywords internal
`[<-.surveydata` <- function(x, i, j, value) {
  has.value <- !missing(value)
  Narg <- nargs() - (has.value) - 1

  has.i <- !missing(i)
  has.j <- !missing(j)
  if (Narg >= 1L & has.j) {
    if (is.character(j)) {
      newname <- j
      w <- which.q(x, j)
      if (length(w) != 0) {
        j <- w
        name <- j
      } else {
        name <- newname
      }
    } else {
      name <- j
    }
  }

  if (Narg == 1L & has.i) {
    if (is.character(i)) {
      newname <- i
      w <- which.q(x, i)
      if (length(w) != 0) {
        i <- w
        name <- i
      } else {
        name <- newname
      }
    } else {
      name <- i
    }
  }

  xorig <- x

  labels <- varlabels(x)
  if (is.null(value)) {
    labels <- labels[-name]
  }
  if (length(w) == 0) {
    labels[newname] <- newname
  }

  ret <- NextMethod("[<-")
  varlabels(ret) <- labels
  as.surveydata(ret, ptn = pattern(xorig), renameVarlabels = FALSE)
}


#' @rdname Extract
#' @aliases $<- $<-.surveydata
#' @param x surveydata object
#' @param name Names of columns
#' @param value New value
#' @method $<- surveydata
#' @usage \method{$}{surveydata}(x, name) <- value
#' @export
#' @keywords internal
#' @seealso [surveydata-package], [varlabels]
`$<-.surveydata` <- function(x, name, value) {
  labels <- varlabels(x)
  if (is.null(value)) {
    labels <- labels[names(labels) != name]
  }
  if (length(grep(name, names(x))) == 0) {
    labels[name] <- name
  }
  x <- as.data.frame(x)
  x <- NextMethod("$<-")
  varlabels(x) <- labels
  as.surveydata(x, renameVarlabels = FALSE)
}