R/tool_pdata.frame.R

Defines functions arrange.pindex arrange.pdata.frame pmerge pseries2pdataframe check.pdata.frame is.pdata.frame pos.index make.fdindex checkNA.index has.index is.index index.panelmodel index.pseries index.pdata.frame index.pindex is.pbalanced.panelmodel is.pbalanced.pgmm is.pbalanced.pmg is.pbalanced.pcce is.pbalanced.pggls is.pbalanced.pseries is.pbalanced.pdata.frame is.pbalanced.data.frame is.pbalanced.default is.pbalanced print.pdim pdim.panelmodel pdim.pgmm pdim.pmg pdim.pcce pdim.pggls pdim.pseries pdim.pdata.frame pdim.data.frame pdim.default pdim is.pseries as.data.frame.pdata.frame as.list.pdata.frame pseriesfy.collapse pseriesfy print.pdata.frame subset_pseries pdata.frame fancy.row.names

Documented in as.data.frame.pdata.frame as.list.pdata.frame index.panelmodel index.pdata.frame index.pindex index.pseries is.pbalanced is.pbalanced.data.frame is.pbalanced.default is.pbalanced.panelmodel is.pbalanced.pcce is.pbalanced.pdata.frame is.pbalanced.pggls is.pbalanced.pgmm is.pbalanced.pmg is.pbalanced.pseries is.pseries pdata.frame pdim pdim.data.frame pdim.default pdim.panelmodel pdim.pcce pdim.pdata.frame pdim.pggls pdim.pgmm pdim.pmg pdim.pseries print.pdata.frame print.pdim pseriesfy

## pdata.frame and pseries are adaptations of respectively data.frame
## and vector for panel data. An index attribute is added to both,
## which is a data.frame containing the indexes. There is no pseries
## function, it is the class of series extracted from a
## pdata.frame. index and pdim functions are used to extract
## respectively the data.frame containing the index and the dimensions
## of the panel

## pdata.frame:
## - $<-
## - [
## - $
## - [[
## - print
## - as.list
## - as.data.frame
## - pseriesfy
## - arrange for dplyr compatibility

## pseries:
## - [
## - print
## - as.matrix
## - plot
## - summary
## - plot.summary
## - print.summary
## - is.pseries

## - pseries2pdataframe (non-exported)
## - pmerge (non-exported)

## pdim:
## - pdim.default
## - pdim.data.frame
## - pdim.pdata.frame
## - pdim.pseries
## - pdim.panelmodel
## - pdim.pgmm
## - print.pdim
 
## index:
## - index.pindex
## - index.pdata.frame
## - index.pseries
## - index.panelmodel
## - is.index (non-exported)
## - has.index (non-exported)
## - checkNA.index (non-exported)
## - pos.index (non-exported)

fancy.row.names <- function(index, sep = "-") {
  ## non-exported
  # assumes index is a list of 2 or 3 factors [not class pindex]
  if (length(index) == 2L) {result <- paste(index[[1L]], index[[2L]], sep = sep)}
  # this in the order also used for sorting (group, id, time):
  if (length(index) == 3L) {result <- paste(index[[3L]], index[[1L]], index[[2L]], sep = sep)}
  return(result)
}




#' pdata.frame: a data.frame for panel data
#' 
#' An object of class 'pdata.frame' is a data.frame with an index
#' attribute that describes its individual and time dimensions.
#' 
#' The `index` argument indicates the dimensions of the panel. It can
#' be: \itemize{
#' \item a vector of two character strings which
#' contains the names of the individual and of the time indexes,
#' \item
#' a character string which is the name of the individual index
#' variable. In this case, the time index is created automatically and
#' a new variable called "time" is added, assuming consecutive and
#' ascending time periods in the order of the original data,
#' \item an integer, the number of individuals. In this case, the data
#' need to be a balanced panel and be organized as a stacked time series
#' (successive blocks of individuals, each block being a time series
#' for the respective individual) assuming consecutive and ascending
#' time periods in the order of the original data. Two new variables
#' are added: "id" and "time" which contain the individual and the
#' time indexes.
#' }
#' 
#' The `"[["` and `"$"` extract a series from the `pdata.frame`.  The
#' `"index"` attribute is then added to the series and a class
#' attribute `"pseries"` is added. The `"["` method behaves as for
#' `data.frame`, except that the extraction is also applied to the
#' `index` attribute.  A safe way to extract the index attribute is to
#' use the function [index()] for 'pdata.frames' (and other objects).
#' 
#' `as.data.frame` removes the index attribute from the `pdata.frame`
#' and adds it to each column. For its argument `row.names` set to 
#' `FALSE` row names are an integer series, `TRUE` gives "fancy" row
#' names; if a character (with length of the resulting data frame),
#' the row names will be the character's elements.
#' 
#' `as.list` behaves by default identical to
#' [base::as.list.data.frame()] which means it drops the
#' attributes specific to a pdata.frame; if a list of pseries is
#' wanted, the attribute `keep.attributes` can to be set to
#' `TRUE`. This also makes `lapply` work as expected on a pdata.frame
#' (see also **Examples**).
#' 
#' @param x a `data.frame` for the `pdata.frame` function and a
#'     `pdata.frame` for the methods,
#' @param i see [Extract()],
#' @param j see [Extract()],
#' @param y one of the columns of the `data.frame`,
#' @param index this argument indicates the individual and time
#'     indexes. See **Details**,
#' @param drop see [Extract()],
#' @param drop.index logical, indicates whether the indexes are to be
#'     excluded from the resulting pdata.frame,
#' @param optional see [as.data.frame()],
#' @param row.names `NULL` or logical, indicates whether "fancy" row
#'     names (combination of individual index and time index) are to
#'     be added to the returned (p)data.frame (`NULL` and `FALSE` have
#'     the same meaning for `pdata.frame`; for
#'     `as.data.frame.pdata.frame` see Details),
#' @param stringsAsFactors logical, indicating whether character
#'     vectors are to be converted to factors,
#' @param replace.non.finite logical, indicating whether values for
#'     which `is.finite()` yields `TRUE` are to be replaced by `NA`
#'     values, except for character variables (defaults to `FALSE`),
#' @param drop.NA.series logical, indicating whether all-`NA` columns
#'     are to be removed from the pdata.frame (defaults to `FALSE`),
#' @param drop.const.series logical, indicating whether constant
#'     columns are to be removed from the pdata.frame (defaults to
#'     `FALSE`),
#' @param drop.unused.levels logical, indicating whether unused levels
#'     of factors are to be dropped (defaults to `FALSE`) (unused
#'     levels are always dropped from variables serving to construct
#'     the index variables),
#' @param keep.attributes logical, only for as.list and as.data.frame
#'     methods, indicating whether the elements of the returned
#'     list/columns of the data.frame should have the pdata.frame's
#'     attributes added (default: FALSE for as.list, TRUE for
#'     as.data.frame),
#' @param name the name of the `data.frame`,
#' @param value the name of the variable to include,
#' @param \dots further arguments passed on to internal usage of  `data.frame`.
#' @return a `pdata.frame` object: this is a `data.frame` with an
#'     `index` attribute which is a `data.frame` with two variables,
#'     the individual and the time indexes, both being factors.  The
#'     resulting pdata.frame is sorted by the individual index, then
#'     by the time index.
#' @export
#' @author Yves Croissant
#' @seealso [index()] to extract the index variables from a
#'     'pdata.frame' (and other objects), [pdim()] to check the
#'     dimensions of a 'pdata.frame' (and other objects), [pvar()] to
#'     check for each variable if it varies cross-sectionally and over
#'     time. To check if the time periods are consecutive per
#'     individual, see [is.pconsecutive()].
#' @keywords classes
#' @examples
#' 
#' # Gasoline contains two variables which are individual and time
#' # indexes
#' data("Gasoline", package = "plm")
#' Gas <- pdata.frame(Gasoline, index = c("country", "year"), drop.index = TRUE)
#' 
#' # Hedonic is an unbalanced panel, townid is the individual index
#' data("Hedonic", package = "plm")
#' Hed <- pdata.frame(Hedonic, index = "townid", row.names = FALSE)
#' 
#' # In case of balanced panel, it is sufficient to give number of
#' # individuals data set 'Wages' is organized as a stacked time
#' # series
#' data("Wages", package = "plm")
#' Wag <- pdata.frame(Wages, 595)
#' 
#' # lapply on a pdata.frame by making it a list of pseries first
#' lapply(as.list(Wag[ , c("ed", "lwage")], keep.attributes = TRUE), lag)
#' 
#' 
pdata.frame <- function(x, index = NULL, drop.index = FALSE, row.names = TRUE,
                        stringsAsFactors = FALSE,
                        replace.non.finite = FALSE,
                        drop.NA.series = FALSE, drop.const.series = FALSE,
                        drop.unused.levels = FALSE, ...) {

    if(inherits(x, "pdata.frame")) {
      if(!is.pdata.frame(x)) {
        # check properties beyond class and if non-compliant, create proper
        # pdata.frame by continuing with pdata.frame function
        wrn.txt <- paste0("input 'x' claims to be a pdata.frame but does not have ",
                          "compliant properties, so tried to re-create a compliant ",
                          "pdata.frame from 'x'")
        warning(wrn.txt)
      }
    }
  
    if(length(index) > 3L){
        stop("'index' can be of length 3 at the most (one index variable for individual, time, group)")
    }
    
    # prune input: x is supposed to be a plain data.frame. Other classes building
    # on top of R's data frame can inject attributes etc. that confuse functions
    # in pkg plm.
    x <- data.frame(x, ...)
    
    # if requested: coerce character vectors to factors
    if (stringsAsFactors) {
        x.char <- names(x)[vapply(x, is.character, FUN.VALUE = TRUE, USE.NAMES = FALSE)]
        for (i in x.char){
            x[[i]] <- factor(x[[i]])
        }
    }
  
    # if requested: replace Inf, -Inf, NaN (everything for which is.finite is FALSE) by NA
    # (for all but any character columns [relevant if stringAsFactors == FALSE])
    if (replace.non.finite) {
      for (i in names(x)) {
        if (!inherits(x[[i]], "character")) {
          x[[i]][!is.finite(x[[i]])] <- NA
        }
      }
    }
  
    # if requested: check and remove complete NA series
    if (drop.NA.series) {
      na.check <- vapply(x, function(x) sum(!is.na(x)) == 0L, FUN.VALUE = TRUE, USE.NAMES = FALSE)
      na.serie <- names(x)[na.check]
      if (length(na.serie) > 0L){
        if (length(na.serie) == 1L)
          cat(paste0("This series is NA and has been removed: ", na.serie, "\n"))
        else
          cat(paste0("These series are NA and have been removed: ", paste(na.serie, collapse = ", "), "\n"))
      }
      x <- x[ , !na.check]
    }

    # if requested: check for constant series and remove
    if (drop.const.series) {
      # -> var() and sd() on factors is deprecated as of R 3.2.3 -> use duplicated()
      cst.check <- vapply(x, function(x) {
                              if (is.factor(x) || is.character(x)) {
                                all(duplicated(x[!is.na(x)])[-1L])
                              } else {
                                x[! is.finite(x)] <- NA # infinite elements set to NA only for this check
                                var(as.numeric(x), na.rm = TRUE) == 0
                              }
                            }, FUN.VALUE = TRUE, USE.NAMES = FALSE)
      
      # following line: bug fixed thanks to Marciej Szelfer
      cst.check <- cst.check | is.na(cst.check)
      cst.serie <- names(x)[cst.check]
      if (length(cst.serie) > 0L){
        if (length(cst.serie) == 1L){
          cat(paste0("This series is constant and has been removed: ", cst.serie, "\n"))
        }
        else{
            cat(paste0("These series are constants and have been removed: ",
                       paste(cst.serie, collapse = ", "), "\n"))
        }
      }
      x <- x[ , !cst.check]
    }
  
    # sanity check for 'index' argument. First, check the presence of a
    # grouping variable, this should be the third element of the index
    # vector or any "group" named element of this vector
    group.name <- NULL
    if (! is.null(names(index)) || length(index) == 3L){
        if (! is.null(names(index))){
            grouppos <- match("group", names(index))
            if (! is.na(grouppos)){
                group.name <- index[grouppos]
                index <- index[- grouppos]
            }
        }
        if (length(index) == 3L){
            group.name <- index[3L]
            index <- index[-3L]
        }
    }
    if (length(index) == 0L) index <- NULL

    # if index is NULL, both id and time are NULL
    if (is.null(index)){
        id <- NULL
        time <- NULL
    }
    # if the length of index is 1, id = index and time is NULL
    if (length(index) == 1L){
        id <- index
        time <- NULL
    }
    # if the length of index is 2, the first element is id, the second
    # is time
    if (length(index) == 2L){
        id <- index[1L]
        time <- index[2L]
    }
    # if both id and time are NULL, the names of the index are the first
    # two names of x
    if (is.null(id) && is.null(time)){
        id.name <- names(x)[1L]
        time.name <- names(x)[2L]
    }
    else{
        id.name <- id
        time.name <- time
    }
    
    # if index is numeric, this indicates a balanced panel with no. of
    # individuals equal to id.name
    if(is.numeric(id.name)){
        if(!is.null(time.name))
            warning("The time index (second element of 'index' argument) will be ignored\n")
        N <- nrow(x)
        if( (N %% id.name) != 0){
            stop(paste0("unbalanced panel, in this case the individual index may not be indicated by an integer\n",
                        "but by specifying a column of the data.frame in the first element of the 'index' argument\n"))
        }
        else{
            T <- N %/% id.name
            n <- N %/% T
            time <- rep((1:T), n)
            id <- rep((1:n), rep(T, n))
            id.name <- "id"
            time.name <- "time"
            if (id.name %in% names(x)) warning(paste0("column '", id.name, "' overwritten by id index"))
            if (time.name %in% names(x)) warning(paste0("column '", time.name, "' overwritten by time index"))
            x[[id.name]] <- id <- as.factor(id)
            x[[time.name]] <- time <- as.factor(time)
        }
    }
    else{
        # id.name is not numeric, i.e., individual index is supplied
        if (!id.name %in% names(x)) stop(paste("variable '", id.name, "' does not exist (individual index)", sep=""))
        if (is.factor(x[[id.name]])){
            id <- x[[id.name]] <- x[[id.name]][drop = TRUE] # drops unused levels of factor
        }
        else{
            id <- x[[id.name]] <- as.factor(x[[id.name]])
        }
        
        if (is.null(time.name)){
            # if no time index is supplied, add time variable
            # automatically order data by individual index, necessary
            # for the automatic addition of time index to be
            # successful if no time index was supplied
            x <- x[order(x[[id.name]]), ]
            Ti <- collapse::qtable(x[[id.name]])
            n <- length(Ti)
            time <- c()
            for (i in seq_len(n)){
                time <- c(time, 1:Ti[i])
            }
            time.name <- "time"
            if (time.name %in% names(x))
                warning(paste0("column '", time.name, "' overwritten by time index"))
            time <- x[[time.name]] <- as.factor(time)
        }
        else{
            # use supplied time index
            if (!time.name %in% names(x))
                stop(paste0("variable '", time.name, "' does not exist (time index)"))
            
            if (is.factor(x[[time.name]])){
                time <- x[[time.name]] <- x[[time.name]][drop = TRUE]
            }
            else{
                time <- x[[time.name]] <- as.factor(x[[time.name]])
            }
        }
    }
    
    # if present, make group variable a factor (just like for id and
    # time variables)
    if (!is.null(group.name)) {
        if (is.factor(x[[group.name]])){
            group <- x[[group.name]] <- x[[group.name]][drop = TRUE]
        }
        else{
            group <- x[[group.name]] <- as.factor(x[[group.name]])
        }
    }
    
    # sort by group (if given), then by id, then by time
    if (! is.null(group.name)) x <- x[order(x[[group.name]], x[[id.name]], x[[time.name]]), ]
    else x <- x[order(x[[id.name]], x[[time.name]]), ]

    # if requested: drop unused levels from factor variables (spare
    # those serving for the index as their unused levels are dropped
    # already (at least in the attribute "index" they need to be
    # dropped b/c much code relies on it))
    if (drop.unused.levels) {
        var.names <- setdiff(names(x), c(id.name, time.name, group.name))
        for (i in var.names){
            if (is.factor(x[[i]])){
                x[[i]] <- droplevels(x[[i]])
            }
        }
    }
    posindex <- match(c(id.name, time.name, group.name), names(x))
    index <- unclass(x[ , posindex]) # unclass to list for speed in subsetting, make it data.frame again later
    if (drop.index) {
        x <- x[ , -posindex, drop = FALSE]
        if (ncol(x) == 0L) warning("after dropping of index variables, the pdata.frame contains 0 columns")
    }

    ### warn if duplicate couples
    test_doub <- collapse::qtable(index[[1L]], index[[2L]], na.exclude = FALSE) # == base R's table(x, y) # == table(index[[1L]], index[[2L]], useNA = "ifany")
    if (any(as.vector(test_doub[!is.na(rownames(test_doub)), !is.na(colnames(test_doub))]) > 1L))
      warning(paste("duplicate couples (id-time) in resulting pdata.frame\n to find out which,",
                    "use, e.g., table(index(your_pdataframe), useNA = \"ifany\")"))
    
    ### warn if NAs in index as likely not sane [not using check.NA because that outputs a line for each dimension -> not needed here]
    if (anyNA(index[[1L]]) || anyNA(index[[2L]]) || (if(length(index) == 3L) anyNA(index[[3L]]) else FALSE))
        warning(paste0("at least one NA in at least one index dimension ",
                       "in resulting pdata.frame\n to find out which, use, e.g., ",
                       "table(index(your_pdataframe), useNA = \"ifany\")\n"))
    
    ### Could also remove rows with NA in any index' dimension
    # drop.rows <- is.na(index[[1L]]) | is.na(index[[2L]])
    # if(ncol(index) == 3L) drop.rows <- drop.rows | is.na(index[[3L]])
    # if((no.drop.rows <- sum(drop.rows)) > 0L) {
    #   x <- x[!drop.rows, ]
    #   index <- index[!drop.rows, ]
    #   txt.drop.rows <- paste0(no.drop.rows, " row(s) dropped in resulting pdata.frame due to NA(s) in at least one index dimension")
    #   warning(txt.drop.rows)
    # }
    
    if (row.names) {
        attr(x, "row.names") <- fancy.row.names(index)
        # NB: attr(x, "row.names") allows for duplicate rownames (as
        # opposed to row.names(x) <- something)
        # NB: no fancy row.names for index attribute (!?):
        # maybe because so it is possible to restore original row.names?
    }
    
    class(index) <- c("pindex", "data.frame")
    attr(x, "index") <- index
    class(x) <- c("pdata.frame", "data.frame")
    
    return(x)
}

#' @rdname pdata.frame
#' @export
"$<-.pdata.frame" <- function(x, name, value) {
  if (inherits(value, "pseries")){
    # remove pseries features before adding value as a column to pdata.frame
    if (length(class(value)) == 1L) value <- unclass(value)
    else attr(value, "class") <- setdiff(class(value), "pseries")
    attr(value, "index") <- NULL
  }
  "$<-.data.frame"(x, name, value)
}

# NB: We don't have methods for [<-.pdata.frame and [[<-.pdata.frame, so these functions
#     dispatch to the respective data.frame methods which assign whatever is
#     handed over to the methods. Especially, if a pseries is handed over, this
#     results in really assigning a pseries to the pdata.frame in case of usage of
#     [<- and [[<-. This is inconsistent because the columns of a pdata.frame do not
#     have the 'pseries' features.
#     This can be seen by lapply(some_pdata.frame, class) after 
#     assigning with the respective .data.frame methods


# Extracting/subsetting method for class pseries, [.pseries, retaining the
# pseries features. est cases are in tests/test_pdata.frame_subsetting.R.
#
# We do not provide a [[.pseries method in addition (note the double "["). Thus,
# the base R method is used and behaviour for pseries is what one would expect 
# and is in line with base R, see ?Extract for [[ with atomic vectors:
# "The usual form of indexing is [. [[ can be used to select a single element
#  dropping names, whereas [ keeps them, e.g., in c(abc = 123)[1]."
# In addition, it also drops other attributes in base R, so applying [[ from
# base R results in dropping names and index which is in line with what one
# would expect for pseries. Example for base R behaviour:
#  a <- 1:10
#  names(a) <- letters[1:10]
#  attr(a, "index") <- "some_index_attribute"
#  a[[3]] # drops names and attribute (a[3] keeps names and drops other attributes)

##### [.pseries is commented because it leads to headache when dplyr is loaded
### boiled down to pkg vctrs https://github.com/r-lib/vctrs/issues/1446
### R.utils::detachPackage("dplyr")
### test_pure <- pcdtest(diff(log(price)) ~ diff(lag(log(price))) + diff(lag(log(price), 2)), data = php)
###
### library(dplyr) # first one will error with [.pseries, for plm 2.4-1 it gives a wrong result (lag is hijacked -> known case)
### test_dplyr        <- pcdtest(diff(price) ~ diff(lag(price)), data = php)
### test_dplyr_plmlag <- pcdtest(diff(log(price)) ~ diff(plm::lag(log(price))) + diff(plm::lag(log(price), 2)), data = php) # save way
##
##
## @rdname pdata.frame
## @export
# "[.pseries" <- function(x, ...) {
# 
#  ## use '...' instead of only one specific argument, because subsetting for
#  ## factors can have argument 'drop', e.g., x[i, drop=TRUE] see ?Extract.factor
#   index <- attr(x, "index")
#   
#   ## two sanity checks as [.pseries-subsetting was introduced in Q3/2021 and some packages
#   ## produced illegal pseries (these pkg errors were fixed by new CRAN releases but maybe
#   ## other code out there produces illegal pseries, so leave these sanity checks in here for
#   ## a while, then remove (for speed)
#     if(is.null(index)) warning("pseries object with is.null(index(pseries)) == TRUE encountered")
#     if(!is.null(index) && !is.index(index)) warning(paste0("pseries object has illegal index with class(index) == ", paste0(class(index), collapse = ", ")))
#   
#   names_orig <- names(x)
#   keep_rownr <- seq_along(x) # full length row numbers original pseries
#   names(keep_rownr) <- names_orig
# 
#   if(is.null(names_orig)) {
#     names(x) <- keep_rownr # if no names are present, set names as integer sequence to identify rows to keep later
#     names(keep_rownr) <- keep_rownr
#   }
#   x <- remove_pseries_features(x)
#   result <- x[...] # actual subsetting
# 
#   # identify rows to keep in the index:
#   keep_rownr <- keep_rownr[names(result)] # row numbers to keep after subsetting
#   names(result) <- if(!is.null(names_orig)) names_orig[keep_rownr] else NULL # restore and subset original names if any
# 
#   # Subset index accordingly:
#   # Check if index is null is a workaround for R's data frame subsetting not
#   # stripping class pseries but its attributes for factor (for other data types, pseries class is dropped)
#   # see https://bugs.r-project.org/bugzilla/show_bug.cgi?id=18140
#   if (!is.null(index)) {
#     index <- index[keep_rownr, ]
#     index <- droplevels(index) # drop unused levels (like in subsetting of pdata.frames)
#   }
# 
#   result <- add_pseries_features(result, index)
#   return(result)
# }

## Non-exported internal function for subsetting of pseries. Can be used
## internally. 
## While there is now a "proper" subsetting function for pseries, leave this
## subset_pseries for a while just to be safe (currently used in pcdtest())
subset_pseries <- function(x, ...) {
  ## use '...' instead of only one specific argument, because subsetting for
  ## factors can have argument 'drop', e.g., x[i, drop=TRUE] see ?Extract.factor
  index <- attr(x, "index")
  if(is.null(index)) warning("pseries object with is.null(index(pseries)) == TRUE encountered")
  if(!is.null(index) && !is.index(index)) warning(paste0("pseries object has illegal index with class(index) == ", paste0(class(index), collapse = ", ")))
  names_orig <- names(x)
  keep_rownr <- seq_along(x) # full length row numbers original pseries
  names(keep_rownr) <- names_orig
  
  if(is.null(names_orig)) {
    names(x) <- keep_rownr # if no names are present, set names as integer sequence to identify rows to keep later
    names(keep_rownr) <- keep_rownr
  }
  x <- remove_pseries_features(x)
  result <- x[...] # actual subsetting
  
  # identify rows to keep in the index:
  keep_rownr <- keep_rownr[names(result)] # row numbers to keep after subsetting
  names(result) <- if(!is.null(names_orig)) names_orig[keep_rownr] else NULL # restore and subset original names if any
  
  # Subset index accordingly:
  # Check if index is null is a workaround for R's data frame subsetting not
  # stripping class pseries but its attributes for factor (for other data types, pseries class is dropped)
  # see https://bugs.r-project.org/bugzilla/show_bug.cgi?id=18140
  if(!is.null(index)) {
    index <- index[keep_rownr, ]
    index <- droplevels(index) # drop unused levels (like in subsetting of pdata.frames)
  }
  
  result <- add_pseries_features(result, index)
  return(result)
}


#' @rdname pdata.frame
#' @export
"[.pdata.frame" <- function(x, i, j, drop) {
    # signature of [.data.frame here
  
    missing.i    <- missing(i)    # missing is only guaranteed to yield correct results,
    missing.j    <- missing(j)    # if its argument was not modified before accessing it
    missing.drop <- missing(drop) # -> save information about missingness
    sc <- sys.call()
    # Nargs_mod to distinguish if called by [] (Nargs_mod == 2L); [,] (Nargs_mod == 3L); [,,] (Nargs_mod == 4L)
    Nargs_mod <- nargs() - (!missing.drop)
  
    ### subset index (and row names) appropriately:
    # subsetting data.frame by only j (x[ , j]) or missing j (x[i]) yields full-row
    # column(s) of data.frame, thus do not subset the index because it needs full rows (original index)
    #
    # subset index if:
    #      * [i,j] (supplied i AND supplied j) (in this case: Nargs_mod == 3L (or 4L depending on present/missing drop))
    #      * [i, ] (supplied i AND missing j)  (in this case: Nargs_mod == 3L (or 4L depending on present/missing drop))
    #
    # do not subset index in all other cases (here are the values of Nargs_mod)
    #      * [ ,j] (missing  i AND j supplied)                   (Nargs_mod == 3L (or 4L depending on present/missing drop))
    #      * [i]   (supplied i AND missing j)                    (Nargs_mod == 2L) [Nargs_mod distinguishes this case from the one where subsetting is needed!]
    #      * [i, drop = TRUE/FALSE] (supplied i AND missing j)   (Nargs_mod == 2L)
    #
    # => subset index (and row names) if: supplied i && Nargs_mod >= 3L
    
    index <- attr(x, "index")
    x.rownames <- row.names(x)
    if (!missing.i && Nargs_mod >= 3L) {
      iindex <- i
      if (is.character(iindex)) {
        # Kevin Tappe 2016-01-04 : in case of indexing (subsetting) a 
        # pdata.frame by a character, the subsetting vector should be 
        # converted to numeric by matching to the row names so that the 
        # index can be correctly subset (by this numeric value).
        # Motivation:
        # Row names of the pdata.frame and row names of the pdata.frame's 
        # index are not guaranteed to be the same!
        iindex <- match(iindex, rownames(x))
      }
      # subset index and row names
      index <- "[.data.frame"(index, iindex, )
      x.rownames <- x.rownames[iindex]
      
      # remove empty levels in index (if any)
      # NB: really do dropping of unused levels? Standard R behaviour is to leave the levels and not drop unused levels
      #     Maybe the dropping is needed for functions like lag.pseries/lagt.pseries to work correctly?
      index <- droplevels(index)
      # NB: use droplevels() rather than x[drop = TRUE] as x[drop = TRUE] can also coerce mode!
      # old (up to rev. 251): index <- data.frame(lapply(index, function(x) x[drop = TRUE]))
    }
    
    ### end of subsetting index
    
    # delete attribute with old index first:
    # this preserves the order of the attributes because 
    # order of non-standard attributes is scrambled by R's data.frame subsetting with `[.`
    # (need to add new index later anyway)
    attr(x, "index") <- NULL
    
    # Set class to "data.frame" first to avoid coercing which enlarges the (p)data.frame 
    # (probably by as.data.frame.pdata.frame).
    # Coercing is the built-in behaviour for extraction from data.frames by "[." (see ?`[.data.frame`) 
    # and it seems this cannot be avoided; thus we need to make sure, not to have any coercing going on
    # which adds extra data (such as as.matrix.pseries, as.data.frame.pdata.frame) by setting the class 
    # to "data.frame" first
    class(x) <- "data.frame"

    # call [.data.frame exactly as [.pdata.frame was called but arg is now 'x'
    # this is necessary because there could be several missing arguments
    # use sys.call (and not match.call) because arguments other than drop may not be named
    # need to evaluate i, j, drop, if supplied, before passing on (do not pass on as the sys.call caught originally)
    sc_mod <- sc
    sc_mod[[1L]] <- quote(`[.data.frame`)
    sc_mod[[2L]] <- quote(x)
    
    if (!missing.i) sc_mod[[3L]] <- i # if present, i is always in pos 3
    if (!missing.j) sc_mod[[4L]] <- j # if present, j is always in pos 4
    if (!missing.drop) sc_mod[[length(sc)]] <- drop # if present, drop is always in last position (4 or 5,
                                                    # depending on the call structure and whether missing j or not)
    
    mydata <- eval(sc_mod)

    if (is.null(dim(mydata))) {
      # if dim is NULL, subsetting did not return a data frame but a vector or a
      #   factor or NULL (nothing more is left)
      if (is.null(mydata)) {
        # since R 3.4.0, NULL cannot have attributes, so special case it
        res <- NULL
      } else {
        # vector or factor -> make it a pseries
        res <- structure(mydata,
                         names = x.rownames,
                         index = index,
                         class = unique(c("pseries", class(mydata))))
      }
    } else {
          # subsetting returned a data.frame -> add attributes to make it a pdata.frame again
          res <- structure(mydata,
                           index = index,
                           class = c("pdata.frame", "data.frame"))
    }
  
    return(res)
}

#' @rdname pdata.frame
#' @export
"[[.pdata.frame" <- function(x, y) {
  index <- attr(x, "index")
  attr(x, "index") <- NULL
  class(x) <- "data.frame"
  result <- "[[.data.frame"(x, y)
  if (!is.null(result)){
    # make extracted column a pseries
    # use this order for attributes to preserve original order of attributes for a pseries
    result <- structure(result,
                        names = row.names(x),
                        class = unique(c("pseries", class(result))),
                        index = index 
                        )
  }
  result
}

#' @rdname pdata.frame
#' @export
"$.pdata.frame" <- function(x, y) {
    "[[.pdata.frame"(x, paste(as.name(y)))
}

#' @rdname pdata.frame
#' @export
print.pdata.frame <- function(x, ...) {
  attr(x, "index") <- NULL
  class(x) <- "data.frame"
  # This is a workaround: print.data.frame cannot handle
  # duplicated row names which are currently possible for pdata frames
  if (collapse::any_duplicated(rownames(x))) {
      print("Note: pdata.frame contains duplicated row names, thus original row names are not printed")
      rownames(x) <- NULL 
  }
  print(x, ...)
}


# pseriesfy() takes a pdata.frame and makes each column a pseries
# names of the pdata.frame are not added to the columns as base R's data.frames
# do not allow for names in columns (but, e.g., a tibble does so since 3.0.0,
# see https://github.com/tidyverse/tibble/issues/837)

#' Turn all columns of a pdata.frame into class pseries.
#' 
#' This function takes a pdata.frame and turns all of its columns into
#' objects of class pseries.
#' 
#' Background: Initially created pdata.frames have as columns the pure/basic
#' class (e.g., numeric, factor, character). When extracting a column from such
#' a pdata.frame, the extracted column is turned into a pseries.
#' 
#'  At times, it can be convenient to apply data transformation operations on
#'  such a `pseriesfy`-ed pdata.frame, see Examples.
#' 
#' @name pseriesfy
#' @param x an object of class `"pdata.frame"`,
#' @param \dots further arguments (currently not used).
#' @return A pdata.frame like the input pdata.frame but with all columns 
#'         turned into pseries. 
#' @seealso [pdata.frame()], [plm::as.list()]
#' @keywords attribute
#' @export
#' @examples
#' library("plm")
#' data("Grunfeld", package = "plm")
#' pGrun <- pdata.frame(Grunfeld[ , 1:4], drop.index = TRUE)
#' pGrun2 <- pseriesfy(pGrun) # pseriesfy-ed pdata.frame
#' 
#' # compare classes of columns
#' lapply(pGrun,  class)
#' lapply(pGrun2, class)
#' 
#' # When using with()
#' with(pGrun,  lag(value)) # dispatches to base R's lag() 
#' with(pGrun2, lag(value)) # dispatches to plm's lag() respect. panel structure
#' 
#' # When lapply()-ing 
#' lapply(pGrun,  lag) # dispatches to base R's lag() 
#' lapply(pGrun2, lag) # dispatches to plm's lag() respect. panel structure
#' 
#' # as.list(., keep.attributes = TRUE) on a non-pseriesfy-ed
#' # pdata.frame is similar and dispatches to plm's lag
#' lapply(as.list(pGrun, keep.attributes = TRUE), lag) 
#' 
pseriesfy <- function(x, ...) { 
  if(!inherits(x, "pdata.frame")) stop("input 'x' needs to be a pdata.frame")
  ix <- attr(x, "index")
  nam <- attr(x, "row.names")
  pdf <- as.data.frame(lapply(x, function(col) add_pseries_features(col, ix)))
  class(pdf) <- c("pdata.frame", class(pdf))
  attr(pdf, "index") <- ix
  rownames(pdf) <- nam
  return(pdf)
}

pseriesfy.collapse <- function(x, ...) {
  if(!inherits(x, "pdata.frame")) stop("input 'x' needs to be a pdata.frame")
  ix <- attr(x, "index")
  return(collapse::dapply(x, function(col) add_pseries_features(col, ix)))
}


# as.list.pdata.frame:
# The default is to behave identical to as.list.data.frame.
# This default is necessary, because some code relies on this 
# behaviour! Do not change this!
#
#  as.list.data.frame does:
#    * unclass
#    * strips all classes but "list"
#    * strips row.names
#
#  By setting argument keep.attributes = TRUE, the attributes of the pdata.frame
#  are preserved by as.list.pdata.frame: a list of pseries is returned
#  and lapply can be used as usual, now working on a list of pseries, e.g.,
#    lapply(as.list(pdata.frame[ , your_cols], keep.attributes = TRUE), lag)
#  works as expected.

#' @rdname pdata.frame
#' @export
as.list.pdata.frame <- function(x, keep.attributes = FALSE, ...) {
    if (!keep.attributes) {
        x <- as.list.data.frame(x)
    } else {
        # make list of pseries objects
        x_names <- names(x)
        x <- lapply(x_names,
                    FUN = function(element, pdataframe){
                        "[[.pdata.frame"(x = pdataframe, y = element)
                    },
                    pdataframe = x)
        names(x) <- x_names
        
    # note: this function is slower than the corresponding
    # as.list.data.frame function,
    # because we cannot simply use unclass() on the pdata.frame:
    # need to add index etc to all columns to get proper pseries
    # back => thus the extraction function "[[.pdata.frame" is used
    }
    return(x)
}

#' @rdname pdata.frame
#' @export
as.data.frame.pdata.frame <- function(x, row.names = NULL, optional = FALSE, keep.attributes = TRUE, ...) {
    index <- attr(x, "index")

    if(!keep.attributes) {
      attr(x, "index") <- NULL
      class(x) <- "data.frame"
      rownames(x) <- NULL
    } else {
      # make each column a pseries (w/o names)
      x <- lapply(x,
                  function(z){
                  #     names(z) <- row.names(x) # it is not possible to keep the names in the 'pseries'/
                                                 # in columns because the call to data.frame later deletes
                                                 # the names attribute of columns (definition of data frame)
                    attr(z, "index") <- index
                    class(z) <- unique(c("pseries", class(z)))
                    return(z)
                  })
    }
    
    if(is.null(row.names)) {
      # do as base::as.data.frame does for NULL
      x <- as.data.frame(x, row.names = NULL)
    } else {
      # argument check
      if(!(isTRUE(row.names) || isFALSE(row.names) || is.character(row.names)))
        stop("argument 'row.names' is none of NULL, FALSE, TRUE, and not a character")
      
      if(is.logical(row.names) && row.names == FALSE) {
        # set row names to integer sequence 1, 2, 3, ...
        x <- as.data.frame(x)
        row.names(x) <- NULL
      }
      if(is.logical(row.names) && row.names == TRUE) {
        # set fancy row names
        x <- as.data.frame(x)
        row.names(x) <- fancy.row.names(index)
      }
      if(is.character(row.names)) {
        x <- as.data.frame(x)
        row.names(x) <- row.names
      }
      
      # using row.names(x) <- "something" is safer (does not allow
      # duplicate row.names) than # attr(x,"row.names") <- "something"
    }
    return(x)
}


#' Check if an object is a pseries
#' 
#' This function checks if an object qualifies as a pseries
#' 
#' A `"pseries"` is a wrapper around a "basic class" (numeric, factor,
#' logical, character, or complex).
#' 
#' To qualify as a pseries, an object needs to have the following
#' features:
#'
#' - class contains `"pseries"` and there are at least two classes
#' (`"pseries"` and the basic class),
#'
#' - have an appropriate index attribute (defines the panel
#' structure),
#'
#' - any of `is.numeric`, `is.factor`, `is.logical`, `is.character`,
#' `is.complex` is `TRUE`.
#' 
#' @param object object to be checked for pseries features
#'
#' @export
#' @return A logical indicating whether the object is a pseries (`TRUE`)
#' or not (`FALSE`).
#' @seealso [pseries()] for some computations on pseries and some
#' further links.
#' @keywords attribute
#' @examples
#' 
#' # Create a pdata.frame and extract a series, which becomes a pseries
#' data("EmplUK", package = "plm")
#' Em <- pdata.frame(EmplUK)
#' z <- Em$output
#' 
#' class(z) # pseries as indicated by class
#' is.pseries(z) # and confirmed by check
#' 
#' # destroy index of pseries and re-check
#' attr(z, "index") <- NA
#' is.pseries(z) # now FALSE
#' 
is.pseries <- function(object) {
 # checks if an object has the necessary features to qualify as a 'pseries'
  res <- TRUE
  if (!inherits(object, "pseries")) res <- FALSE
  # class 'pseries' is always on top of basic class: min 2 classes needed, if 2 classes "pseries" needs to be first entry
  if (!length(class(object)) >= 2L) res <- FALSE
  if (length(class(object)) == 2L && class(object)[1L] != "pseries") res <- FALSE
  if (!has.index(object)) res <- FALSE
  if (!any(c(is.numeric(object), is.factor(object), is.logical(object), 
             is.character(object), is.complex(object)))) {
    res <- FALSE
  }
  
  return(res)
}


#' Check for the Dimensions of the Panel
#' 
#' This function checks the number of individuals and time observations in the
#' panel and whether it is balanced or not.
#' 
#' `pdim` is called by the estimation functions and can be also used
#' stand-alone.
#'
#' @name pdim
#' @aliases pdim
#' @param x a `data.frame`, a `pdata.frame`, a `pseries`, a
#'     `panelmodel`, or a `pgmm` object,
#' @param y a vector,
#' @param index see [pdata.frame()],
#' @param \dots further arguments.
#' @return An object of class `pdim` containing the following
#'     elements:
#' 
#' \item{nT}{a list containing `n`, the number of individuals, `T`,
#' the number of time observations, `N` the total number of
#' observations,}
#'
#' \item{Tint}{a list containing two vectors (of type integer): `Ti`
#' gives the number of observations for each individual and `nt` gives
#' the number of individuals observed for each period,}
#'
#' \item{balanced}{a logical value: `TRUE` for a balanced panel,
#' `FALSE` for an unbalanced panel,}
#'
#' \item{panel.names}{a list of character vectors: `id.names` contains
#' the names of each individual and `time.names` contains the names of
#' each period.}
#'
#' @note Calling `pdim` on an estimated `panelmodel` object
#'     and on the corresponding `(p)data.frame` used for this
#'     estimation does not necessarily yield the same result. When
#'     called on an estimated `panelmodel`, the number of
#'     observations (individual, time) actually used for model
#'     estimation are taken into account.  When called on a
#'     `(p)data.frame`, the rows in the `(p)data.frame` are
#'     considered, disregarding any `NA` values in the dependent or
#'     independent variable(s) which would be dropped during model
#'     estimation.
#' @export
#' @author Yves Croissant
#' @seealso [is.pbalanced()] to just determine balancedness
#'     of data (slightly faster than `pdim`),\cr
#'     [punbalancedness()] for measures of
#'     unbalancedness,\cr [nobs()],
#'     [pdata.frame()],\cr [pvar()] to check for
#'     each variable if it varies cross-sectionally and over time.
#' @keywords attribute
#' @examples
#' 
#' # There are 595 individuals
#' data("Wages", package = "plm")
#' pdim(Wages, 595)
#' 
#' # Gasoline contains two variables which are individual and time
#' # indexes and are the first two variables
#' data("Gasoline", package="plm")
#' pdim(Gasoline)
#' 
#' # Hedonic is an unbalanced panel, townid is the individual index
#' data("Hedonic", package = "plm")
#' pdim(Hedonic, "townid")
#' 
#' # An example of the panelmodel method
#' data("Produc", package = "plm")
#' z <- plm(log(gsp)~log(pcap)+log(pc)+log(emp)+unemp,data=Produc,
#'          model="random", subset = gsp > 5000)
#' pdim(z)
#' 
pdim <- function(x, ...) {
  UseMethod("pdim")
}

#' @rdname pdim
#' @export
pdim.default <- function(x, y, ...) {
  if (length(x) != length(y)) stop("The length of the two inputs differs\n")
  x <- x[drop = TRUE] # drop unused factor levels so that table() 
  y <- y[drop = TRUE] # gives only needed combinations
  z <- collapse::qtable(x, y) ## == base R's table(x, y)
  Ti <- rowSums(z) # faster than: apply(z, 1, sum)
  nt <- colSums(z) #              apply(z, 2, sum)
  n <- nrow(z)
  T <- ncol(z)
  N <- length(x)
  nT <- list(n = n, T = T, N = N)
  id.names <- rownames(z)
  time.names <- colnames(z)
  panel.names <- list(id.names = id.names, time.names = time.names)
  balanced <- if(any(z <- as.vector(z) == 0)) FALSE else TRUE
  if(any(z > 1)) stop("duplicate couples (id-time)\n")
  Tint <- list(Ti = Ti, nt = nt)
  z <- list(nT = nT, Tint = Tint, balanced = balanced, panel.names = panel.names)
  class(z) <- "pdim"
  z
}

#' @rdname pdim
#' @export
pdim.data.frame <- function(x, index = NULL, ...) {
  x <- pdata.frame(x, index)
  index <- unclass(attr(x, "index"))
  pdim(index[[1L]], index[[2L]])
}

#' @rdname pdim
#' @export
pdim.pdata.frame <- function(x,...) {
  index <- unclass(attr(x, "index"))
  pdim(index[[1L]], index[[2L]])
}

#' @rdname pdim
#' @export
pdim.pseries <- function(x,...) {
  index <- unclass(attr(x, "index"))
  pdim(index[[1L]], index[[2L]])
}

#' @rdname pdim
#' @export
pdim.pggls <- function(x, ...) {
  ## pggls is also class panelmodel, but take advantage of the pdim attribute in it
  attr(x, "pdim")
}

#' @rdname pdim
#' @export
pdim.pcce <- function(x, ...) {
  ## pcce is also class panelmodel, but take advantage of the pdim attribute in it
  attr(x, "pdim")
}

#' @rdname pdim
#' @export
pdim.pmg <- function(x, ...) {
  ## pmg is also class panelmodel, but take advantage of the pdim attribute in it
  attr(x, "pdim")
}

#' @rdname pdim
#' @export
pdim.pgmm <- function(x, ...) {
## pgmm is also class panelmodel, but take advantage of the pdim attribute in it
  attr(x, "pdim")
}

#' @rdname pdim
#' @export
pdim.panelmodel <- function(x, ...) {
  x <- model.frame(x)
  pdim(x)
}

#' @rdname pdim
#' @export
print.pdim <- function(x, ...) {
  if (x$balanced){
      cat("Balanced Panel: ")
      cat(paste("n = ", x$nT$n, ", ", sep=""))
      cat(paste("T = ", x$nT$T, ", ", sep=""))
      cat(paste("N = ", x$nT$N, "\n", sep=""))
  }
  else{
      cat("Unbalanced Panel: ")
      cat(paste("n = ", x$nT$n,", ", sep=""))
      cat(paste("T = ", min(x$Tint$Ti), "-", max(x$Tint$Ti), ", ", sep=""))
      cat(paste("N = ", x$nT$N, "\n", sep=""))
  }
  invisible(pdim)
}

########### is.pbalanced ##############
### for convenience and to be faster than pdim() for the purpose
### of the determination of balancedness only, because it avoids
### pdim()'s calculations which are unnecessary for balancedness.
###
### copied (and adapted) methods and code from pdim.*
### (only relevant parts to determine balancedness)


#' Check if data are balanced
#' 
#' This function checks if the data are balanced, i.e., if each individual has
#' the same time periods
#' 
#' Balanced data are data for which each individual has the same time periods.
#' The returned values of the `is.pbalanced(object)` methods are identical
#' to `pdim(object)$balanced`.  `is.pbalanced` is provided as a short
#' cut and is faster than `pdim(object)$balanced` because it avoids those
#' computations performed by `pdim` which are unnecessary to determine the
#' balancedness of the data.
#' 
#' @aliases is.pbalanced
#' @param x an object of class `pdata.frame`, `data.frame`,
#'     `pseries`, `panelmodel`, or `pgmm`,
#' @param y (only in default method) the time index variable (2nd index
#' variable),
#' @param index only relevant for `data.frame` interface; if
#'     `NULL`, the first two columns of the data.frame are
#'     assumed to be the index variables; if not `NULL`, both
#'     dimensions ('individual', 'time') need to be specified by
#'     `index` as character of length 2 for data frames, for
#'     further details see [pdata.frame()],
#' @param \dots further arguments.
#' @return A logical indicating whether the data associated with
#'     object `x` are balanced (`TRUE`) or not
#'     (`FALSE`).
#' @seealso [punbalancedness()] for two measures of
#'     unbalancedness, [make.pbalanced()] to make data
#'     balanced; [is.pconsecutive()] to check if data are
#'     consecutive; [make.pconsecutive()] to make data
#'     consecutive (and, optionally, also balanced).\cr
#'     [pdim()] to check the dimensions of a 'pdata.frame'
#'     (and other objects), [pvar()] to check for individual
#'     and time variation of a 'pdata.frame' (and other objects),
#'     [pseries()], [data.frame()],
#'     [pdata.frame()].
#' @export
#' @keywords attribute
#' @examples
#' 
#' # take balanced data and make it unbalanced
#' # by deletion of 2nd row (2nd time period for first individual)
#' data("Grunfeld", package = "plm")
#' Grunfeld_missing_period <- Grunfeld[-2, ]
#' is.pbalanced(Grunfeld_missing_period)     # check if balanced: FALSE
#' pdim(Grunfeld_missing_period)$balanced    # same
#' 
#' # pdata.frame interface
#' pGrunfeld_missing_period <- pdata.frame(Grunfeld_missing_period)
#' is.pbalanced(Grunfeld_missing_period)
#' 
#' # pseries interface
#' is.pbalanced(pGrunfeld_missing_period$inv)
#' 
is.pbalanced <- function(x, ...) {
  UseMethod("is.pbalanced")
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.default <- function(x, y, ...) {
  if (length(x) != length(y)) stop("The length of the two inputs differs\n")
  x <- x[drop = TRUE] # drop unused factor levels so that table 
  y <- y[drop = TRUE] # gives only needed combinations
  z <- collapse::qtable(x, y) # == base R's table(x, y)
  balanced <- if(any(v <- as.vector(z) == 0L)) FALSE else TRUE
  if (any(v > 1L)) warning("duplicate couples (id-time)\n")
  balanced
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.data.frame <- function(x, index = NULL, ...) {
  x <- pdata.frame(x, index)
  index <- unclass(attr(x, "index")) # unclass for speed
  is.pbalanced(index[[1L]], index[[2L]])
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.pdata.frame <- function(x, ...) {
  index <- unclass(attr(x, "index")) # unclass for speed
  is.pbalanced(index[[1L]], index[[2L]])
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.pseries <- function(x, ...) {
  index <- unclass(attr(x, "index")) # unclass for speed
  is.pbalanced(index[[1L]], index[[2L]])
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.pggls <- function(x, ...) {
  # pggls is also class panelmodel, but take advantage of its pdim attribute
  attr(x, "pdim")$balanced
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.pcce <- function(x, ...) {
  # pcce is also class panelmodel, but take advantage of its pdim attribute
  attr(x, "pdim")$balanced
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.pmg <- function(x, ...) {
  # pmg is also class panelmodel, but take advantage of its pdim attribute
  attr(x, "pdim")$balanced
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.pgmm <- function(x, ...) {
  # pgmm is also class panelmodel, but take advantage of its pdim attribute
  attr(x, "pdim")$balanced
}

#' @rdname is.pbalanced
#' @export
is.pbalanced.panelmodel <- function(x, ...) {
  x <- model.frame(x)
  is.pbalanced(x)
}

#' Extract the indexes of panel data
#' 
#' This function extracts the information about the structure of the
#' individual and time dimensions of panel data. Grouping information
#' can also be extracted if the panel data were created with a
#' grouping variable.
#' 
#' Panel data are stored in a `"pdata.frame"` which has an `"index"`
#' attribute. Fitted models in `"plm"` have a `"model"` element which
#' is also a `"pdata.frame"` and therefore also has an `"index"`
#' attribute. Finally, each series, once extracted from a
#' `"pdata.frame"`, becomes of class `"pseries"`, which also has this
#' `"index"` attribute.  `"index"` methods are available for all these
#' objects.  The argument `"which"` indicates which index should be
#' extracted. If `which = NULL`, all indexes are extracted. `"which"`
#' can also be a vector of length 1, 2, or 3 (3 only if the pdata
#' frame was constructed with an additional group index) containing
#' either characters (the names of the individual variable and/or of
#' the time variable and/or the group variable or `"id"` and `"time"`)
#' and `"group"` or integers (1 for the individual index, 2 for the
#' time index, and 3 for the group index (the latter only if the pdata
#' frame was constructed with such).)
#' 
#' @name index.plm
#' @aliases index
#' @importFrom zoo index 
#' @export index
#' @param x an object of class `"pindex"`, `"pdata.frame"`,
#'     `"pseries"` or `"panelmodel"`,
#' @param which the index(es) to be extracted (see details),
#' @param \dots further arguments.
#' @return A vector or an object of class `c("pindex","data.frame")`
#'     containing either one index, individual and time index, or (any
#'     combination of) individual, time and group indexes.
#' @author Yves Croissant
#' @seealso [pdata.frame()], [plm()]
#' @keywords attribute
#' @examples
#' 
#' data("Grunfeld", package = "plm")
#' Gr <- pdata.frame(Grunfeld, index = c("firm", "year"))
#' m <- plm(inv ~ value + capital, data = Gr)
#' index(Gr, "firm")
#' index(Gr, "time")
#' index(Gr$inv, c(2, 1))
#' index(m, "id")
#' 
#' # with additional group index
#' data("Produc", package = "plm")
#' pProduc <- pdata.frame(Produc, index = c("state", "year", "region"))
#' index(pProduc, 3)
#' index(pProduc, "region")
#' index(pProduc, "group")
#'
NULL

#' @rdname index.plm
#' @export
index.pindex <- function(x, which = NULL, ...) {

    if (is.null(which)) {
      # if no specific index is requested, select all index variables
      which <- names(x)
    }
    else{
      # catch case when someone enters "individual" albeit proper value is
      # "id" to extract individual index
      posindividual <- match("individual", which)
      if (! is.na(posindividual)) which[posindividual] <- "id"
    }
    if (length(which) >  3L) stop("the length of argument 'which' should be at most 3")
    if (is.numeric(which)){
        if (! all(which %in% 1:3))
            stop("if integer, argument 'which' should contain only 1, 2 and/or 3")
        if (ncol(x) == 2L && 3 %in% which) stop("no grouping variable, only 2 indexes")
        which <- names(x)[which]
    }
    nindex <- names(x)
    gindex <- c("id", "time")
    if (ncol(x) == 3L) gindex <- c(gindex, "group")
    if (any(! which %in% c(nindex, gindex))) stop("unknown variable")
    if ("id"    %in% which) {
      which[which == "id"]    <- names(x)[1L]
      if("id" %in% names(x)[-1L]) warning("an index variable not being the invidiual index is called 'id'. Likely, any results are distorted.") 
    }
    if ("time"  %in% which) {
      which[which == "time"]  <- names(x)[2L]
      if("time" %in% names(x)[-2L]) warning("an index variable not being the time index is called 'time'. Likely, any results are distorted.") 
    }
    if (ncol(x) == 3L) if ("group" %in% which) {
      which[which == "group"] <- names(x)[3L]
      if("group" %in% names(x)[-3L]) warning("an index variable not being the group index is called 'group'. Likely, any results are distorted.") 
    }
    
    result <- x[ , which]
    result
}

#' @rdname index.plm
#' @export
index.pdata.frame <- function(x, which = NULL, ...) {
  anindex <- attr(x, "index")
  index(x = anindex, which = which)
}

#' @rdname index.plm
#' @export
index.pseries <- function(x, which = NULL, ...) {
  anindex <- attr(x, "index")
  index(x = anindex, which = which)
}
  
#' @rdname index.plm
#' @export
index.panelmodel <- function(x, which = NULL, ...) {
  anindex <- attr(x$model, "index")
  index(x = anindex, which = which)
}


is.index <- function(index) {
  # not exported, helper function
  # checks if the index is an index in the sense of package plm
  res <- TRUE
  if(!all(class(index) == c("pindex", "data.frame"))) res <- FALSE
  if(!is.null(n <- ncol(index)) && !(n %in% c(2, 3))) res <- FALSE
  res
}

has.index <- function(object) {
  # not exported, helper function
  # checks if an object has an index in sense of package plm
  # (esp. to distinguish from zoo::index() which always returns an index)
  index <- attr(object, "index")
  return(is.index(index))
}

checkNA.index <- function(index, which = "all", error = TRUE) {
  # not exported, helper function
  #
  # check if any NA in indexes (all or specific dimension)
  # 
  # index can be of class pindex (proper index attribute of pdata.frame/pseries
  # or a list of factors, thus can call checkNA.index(unclass(proper_index))) 
  # which gives a speed up as the faster list-subetting is used (instead of the
  # relatively slower data.frame-subsetting)
  
  feedback <- if(error) stop else warning

  if(which == "all") {
    if(anyNA(index[[1L]])) feedback("NA in the individual index variable")
    if(anyNA(index[[2L]])) feedback("NA in the time index variable")
    n.index <- if(inherits(index, "pindex")) ncol(index) else length(index) # else-branch is list (for speed)
    if(n.index == 3L) { if(anyNA(index[[3L]])) feedback("NA in the group index variable") }
  }
  if(which == 1L) {
    if(anyNA(index[[1L]])) feedback("NA in the individual index variable")
  }
  if(which == 2L) {
    if(anyNA(index[[2L]])) feedback("NA in the time index variable")
  }
  if(which == 3L) {
    if(anyNA(index[[3L]])) feedback("NA in the group index variable")
  }
  NULL
}


make.fdindex <- function(x) {
  ## non-exported helper function
  ## constructs an index suitable for time-wise first-difference data
  ## input: an index (class c("pindex", "data.frame"))
  ## return value: plain 2-entry list of the index factors
  ix <- unclass(x)
  
  ix.ind.lag <- lag(add_pseries_features(ix[[1L]], ix))
  ix.ti.lag  <- lag(add_pseries_features(ix[[2L]], ix))

  na <- is.na(ix.ind.lag) # NAs are in same positions for ind and time index

  ix.ind.lag <- ix.ind.lag[!na]
  ix.ti.lag  <- ix.ti.lag[!na]
  
  list(ix.ind.lag, ix.ti.lag)
}


# pos.index:
# not exported, helper function
#
# determines column numbers of the index variables in a pdata.frame
# returns named numeric of length 2 or 3 with column numbers of the index variables
# (1: individual index, 2: time index, if available 3: group index), 
# names are the names of the index variables
#
# returns c(NA, NA) / c(NA, NA, NA) if the index variables are not a column in the pdata.frame
# (e.g., for pdata.frames created with drop.index = TRUE).
# Cannot detect index variables if their columns names were changed after creation of the pdata.frame

pos.index <- function(x, ...) {
  index <- attr(x, "index")
  index_names <- names(index)
  index_pos <- match(index_names, names(x))
  names(index_pos) <- index_names
  return(index_pos)
}

is.pdata.frame <- function(x, feedback = NULL) {
  # not exported, helper function
  # checks if a pdata.frame has appropriate properties

  res <- TRUE
  if(!inherits(x, "pdata.frame")) res <- FALSE
  if(!has.index(x))               res <- FALSE
  if(!nrow(index(x)) == nrow(x))  res <- FALSE
  
  if(!res && !is.null(feedback)) {
    feedback <- switch(feedback,
                       "error" = stop,
                       "warn"  = warning)
    feedback.txt <- paste0("input data claims to be a pdata.frame but does not seem to have compliant properties, ",
                           "results can be unreliable. This can happen due to data manipulation by ",
                           "non-pdata.frame-aware functions (e.g., 'dplyr' on pdata.frame). \n Maybe re-create ",
                           "data input as fresh pdata.frame after last data manipulation with other tools.")
    feedback(feedback.txt)
  }
  res
}

check.pdata.frame <- function(x) {
  # not exported, helper function
  # checks if a pdata.frame has appropriate properties
  # Like is.pdata.frame but with error output about ill-specification
  stopifnot(inherits(x, "pdata.frame"))
  stopifnot(has.index(x))
  stopifnot(nrow(index(x)) == nrow(x))
  NULL
}

pseries2pdataframe <- function(x, pdata.frame = TRUE, ...) {
  ## non-exported
  ## Transforms a pseries in a (p)data.frame with the indices as regular columns
  ## in positions 1, 2 and (if present) 3 (individual index, time index, group index).
  ## if pdataframe = TRUE -> return a pdata.frame, if FALSE -> return a data.frame
  ## ellipsis (dots) passed on to pdata.frame()
  if(!inherits(x, "pseries")) stop("input needs to be of class 'pseries'")
  indices <- attr(x, "index")
  class(indices) <- setdiff(class(indices), "pindex")
  vx <- remove_pseries_features(x)
  dfx <- cbind(indices, vx)
  dimnames(dfx)[[2L]] <- c(names(indices), deparse(substitute(x)))
  res <- if(pdata.frame == TRUE) {
    pdata.frame(dfx, index = names(indices), ...)
  } else { dfx }
  return(res)
}

pmerge <- function(x, y, ...) {
  ## non-exported
  ## Returns a data.frame, not a pdata.frame.
  ## pmerge is used to merge pseries or pdata.frames into a data.frame or
  ## to merge a pseries to a data.frame
  
  ## transf. if pseries or pdata.frame
  if(inherits(x, "pseries")) x <- pseries2pdataframe(x, pdata.frame = FALSE)
  if(inherits(y, "pseries")) y <- pseries2pdataframe(y, pdata.frame = FALSE)
  if(inherits(x, "pdata.frame")) x <- as.data.frame(x, keep.attributes = FALSE)
  if(inherits(y, "pdata.frame")) y <- as.data.frame(y, keep.attributes = FALSE)
  
  # input to merge() needs to be data.frames; not yet suitable for 3rd index (group variable)
  z <- merge(x, y,
             by.x = dimnames(x)[[2L]][1:2],
             by.y = dimnames(y)[[2L]][1:2], ...)
  return(z)
}

## dplyr "compatibility"/awareness/warning, see https://github.com/ycroissant/plm/issues/46
# test in test_pdata.frame_compliant.R
# 
# Approach: Avoid dplyr-dependency albeit registering methods for it, needs the
# utils::globalVariables() statement to avoid a NOTE in R CMD check about 
# undefined global variable.
# Shall CRAN ever increase the code checking strictness, the approach with a
# Suggests-dependency is given commented below as well.
utils::globalVariables("arrange")
#' @rawNamespace if(getRversion() >= "3.6.0") {S3method(dplyr::arrange, pdata.frame)}
arrange.pdata.frame <- function(.data, ..., .by_group = FALSE, .locale = NULL) {
  # function signature of dplyr:::arrange.data.frame
  idx <- index(.data)
  ag.data <- NextMethod()
  ag.idx <- arrange(idx, ..., .by_group = FALSE, .locale = NULL) # dispatches to arrange.pindex
  attr(ag.data, "index") <- ag.idx
  ag.data
}

#' @rawNamespace if(getRversion() >= "3.6.0") {S3method(dplyr::arrange, pindex)}
arrange.pindex <- function(.data, ..., .by_group = .by_group, .locale = .locale) {
  NextMethod()
}

### alternatives
# arrange.pdata.frame <- function(.data, ..., .by_group = FALSE, .locale = NULL) {
#   ### this alternative would require dplyr to be at least a Suggests-dependency
#   stopifnot(requireNamespace("dplyr"))
#   idx <- index(.data)
#   ag.df  <- dplyr::arrange(.data, ..., .by_group = FALSE, .locale = NULL)
#   ag.idx <- dplyr::arrange(idx,   ..., .by_group = FALSE, .locale = NULL)
#   attr(ag.df, "index") <- ag.idx
#   ag.df
# }

# arrange.pdata.frame <- function(.data, ..., .by_group = FALSE, .locale = NULL) {
#   # this alternative just warns and executes dplyr's plain arrange destroying the index
#   wrn <- paste0("dplyr::arrange not safe on pdata.frames!\n",
#                 "Before input to estimation and test functions of package plm, ",
#                 "create a fresh pdata.frame from the dplyr-manipulated data to be safe")
#   warning(wrn)
#   NextMethod()
# }

Try the plm package in your browser

Any scripts or data that you put into this service are public.

plm documentation built on June 22, 2024, 6:54 p.m.