R/get.atr.R

In ILSAmerge: Merge and Download International Large-Scale Assessments (ILSA) Data

#' Retrieve tibble attributes
#'
#' Retrieves attributes from a tibble object created by haven.
#' 
#' @param tibble a tibble object.
#' @param NULLasNA a logical value indicating if \code{NULL} attributes
#' should be listed as NA. Default is \code{TRUE}.
#' @inheritParams base::attr
#' @param aslist a logical value indicating if output should be a list.
#'
#' @returns A list or a data frame.
#' 
#' 
#' @keywords tibblemanagement
#' 
#' @examples
#' # tibble generated by haven
#' input <- system.file("extdata/reds", package = "ILSAmerge")
#' x <- do.call(rbind,justload(inputdir = input,population = "BCGV1"))
#' x
#' 
#' # Get an attribute
#' get.atr(tibble = x, which = "label")[1:3]
#' get.atr(tibble = x, which = "labels")[1:3]
#' get.atr(tibble = x, which = "format.spss")[1:3]
#' 
#' # Get NAs
#' get.nas(tibble = x,aslist = TRUE)[10:20]
#' get.nas(tibble = x,aslist = FALSE)[10:20,]
#' 
#' # Get variable labels
#' get.varlab(tibble = x)[10:20,]
#'
#' @export
#

#' @rdname get.atr
#' @export
get.atr <- function(tibble, which, NULLasNA = TRUE, exact = FALSE){
  
  # Checks ------------------------------------------------------------------
  
  if(!inherits(tibble, "tbl_df"))
    stop(c("\nInvalid input for 'tibble'.",
           "\nIt should be a tibble."),call. = FALSE)
  
  if(!(isTRUE(NULLasNA)|isFALSE(NULLasNA)))
    stop(c("\nInvalid input for 'NULLasNA'.",
           "\nIt should be a logical value."),call. = FALSE)

# Process & Output --------------------------------------------------------

  
  out <- lapply(1:ncol(tibble), function(i){
    atr <- attr(tibble[,i,drop = TRUE],which, exact = exact)
    
    if(NULLasNA&&is.null(atr)){return(NA)}
    
    return(atr)
    
  })
  names(out) <- colnames(tibble)
  
  return(out)
  
}

#' @rdname get.atr
#' @export
get.nas <- function(tibble, aslist = TRUE){
  
  # Checks ------------------------------------------------------------------
  
  if(!inherits(tibble, "tbl_df"))
    stop(c("\nInvalid input for 'tibble'.",
           "\nIt should be a tibble."),call. = FALSE)
  
  if(!(isTRUE(aslist)|isFALSE(aslist)))
    stop(c("\nInvalid input for 'aslist'.",
           "\nIt should be a logical value."),call. = FALSE)
  
  
  # Process & Output --------------------------------------------------------
  
  nav <- get.atr(tibble,"na_values",NULLasNA = FALSE)
  nar <- get.atr(tibble,"na_range",NULLasNA = FALSE)
  nar <- lapply(nar,function(i) if(is.null(i)){NULL}else{min(i):max(i)})
  
  out <- lapply(1:length(nav),function(i) sort(c(nav[[i]],nar[[i]])))
  names(out) <- colnames(tibble)
  out
  
  if(aslist)
    return(out)
  
  
  out <- cbind.data.frame(name = names(out),
                          NAs = unlist(lapply(out,function(i) paste0(i,collapse = ";"))))
  rownames(out) <- NULL
  return(out)
  
}

#' @rdname get.atr
#' @export
get.varlab <- function(tibble){
  

# Checks ------------------------------------------------------------------

  if(!inherits(tibble, "tbl_df"))
    stop(c("\nInvalid input for 'tibble'.",
           "\nIt should be a tibble."),call. = FALSE)
  
  
  # Process & Output --------------------------------------------------------
  
  out <- unlist(get.atr(tibble,"label",NULLasNA = TRUE))
  out <- cbind.data.frame(name = names(out),
                          varlab = out)
  rownames(out) <- NULL
  return(out)
}