R/methods.R

In finbif: Interface for the 'Finnish Biodiversity Information Facility' API

# accessor methods -------------------------------------------------------------
#' @noRd
#' @export
`[.finbif_occ` <- function(
  x,
  i,
  j,
  drop = FALSE
) {
  n_args <- nargs()

  if (!missing(drop)) {
    n_args <- n_args - 1L
  }

  has_i  <- !missing(i)
  has_j  <- !missing(j)

  nrows <- nrow(x)
  ncols <- ncol(x)
  rows <- seq_len(nrows)
  cols <- seq_len(ncols)

  if (n_args < 3L) {
    if (has_i) {
      cols <- i
    }

  } else {
    if (has_j) {
      cols <- j
    }

    if (has_i) {
      if (is.logical(i)) {
        i <- rep_len(i, nrows)
        i <- which(i)
      }

      rows <- i

    }
  }

  if (has_j) {
    ans <- NextMethod("[", drop = drop)
  } else {
    ans <- NextMethod("[")
  }

  ans <- structure(as.data.frame(ans), class = class(x))
  attr <- attributes(x)
  rows <- as.integer(rows)
  attr[["row.names"]] <- rows
  id <- attr[["record_id"]]
  attr[["record_id"]] <- id[rows]
  mostattributes(ans) <- attr
  nms <- names(x)

  if (!is.character(cols)) {
    cols <- nms[cols]
  }

  names(ans) <- cols
  ans
}

# rbind methods ----------------------------------------------------------------
#' @noRd
#' @export
rbind.finbif_occ <- function(...) {
  ans <- rbind.data.frame(...)
  l <- list(...)

  for (i in c("nrec_dnld", "nrec_avl", "url", "time", "record_id")) {
    a <- lapply(l, attr, i)
    attr(ans, i) <- unlist(a)
  }

  ans
}

# print methods ----------------------------------------------------------------
#' @noRd
#' @export
print.finbif_taxa_list <- function(
  x,
  ...
) {
  ranks <- names(x)

  nms <- unname(x)
  nms <- unlist(nms)
  nms <- names(nms)

  padl <- 0L

  if (!is.null(ranks)) {
    padl <- nchar(ranks)
    padl <- max(padl) + 2L
  }

  padl <- paste0("[%-", padl, "s")
  padr <- 0L

  if (!is.null(nms)) {
    padr <- nchar(nms)
    padr <- max(padr)
  }

  padr <- paste0("%-", padr, "s] ")

  for (i in seq_along(x)) {
    rank <- ranks[[i]]
    no_rank <- is.null(rank) || identical(rank, "")
    rank <- paste0(rank, ": ")

    if (no_rank) {
      rank <- ""
    }

    rank <- sprintf(padl, rank)
    xi <- x[[i]]

    for (j in seq_along(xi)) {
      taxon <- xi[j]
      nm <- names(taxon)
      nm <- sprintf(padr, nm)
      taxon_is_na <- is.na(taxon)
      taxon <- sprintf("ID: %s\n", taxon)

      if (taxon_is_na) {
        taxon <- "Not found\n"
      }

      cat(rank, nm, taxon, sep = "")
    }
  }

  invisible(x)
}

#' @noRd
#' @export
print.finbif_metadata_df <- function(
  x,
  ...,
  right = FALSE
) {
  df <- x
  sl <- getOption("width") / ncol(df)
  sl <- max(9L, sl)

  for (col in names(df)) {
    if (is.character(df[[col]])) {
      n <- nchar(col)
      n <- max(sl, n)
      df[[col]] <- truncate_string(df[[col]], n)
    }
  }

  print.data.frame(df, ..., right = right)
  invisible(x)
}

#' @noRd
#' @export
print.finbif_occ <- function(
  x,
  ...
) {
  dwdth <- getOption("width")
  ncols <- ncol(x)
  nrows <- nrow(x)
  dsply_nr <- min(10L, nrows)
  msg_obj <- list(x, width = dwdth, dnld = "downloaded", avl = "available")
  records_msg(msg_obj)
  cat("A data.frame [", nrows, " x ", ncols, "]\n", sep = "")
  sq <- seq_len(dsply_nr)
  df <- x[sq, , drop = FALSE]
  colnames <- names(df)
  colname_widths <- vapply(colnames, nchar, 0L)
  widths <- colname_widths

  if (nrows > 0L) {
    obj <- list(df = df, colname_widths = colname_widths)
    df <- format_cols(obj)
    widths <- apply(df, 2L, nchar)
    dim(widths) <- dim(df)
    na_widths <- is.na(widths)
    widths[na_widths] <- 4L
    widths <- apply(widths, 2L, max, na.rm = TRUE)
    widths <- pmax(colname_widths, widths)
  }

  dsply_nc <- 0L
  cumulative_width <- 1L

  if (dsply_nr > 9L) {
    cumulative_width <-  2L
  }

  for (width in widths) {
    i <- dsply_nc + 1L
    cumulative_width <- cumulative_width + widths[[i]] + 1L

    if (cumulative_width > dwdth) {
      break
    }

    dsply_nc <- i
  }

  dsply_cols <- seq_len(dsply_nc)
  print.data.frame(df[, dsply_cols])

  extras_obj <- list(
    x,
    rows = nrows - dsply_nr,
    cols = ncols - dsply_nc,
    dc = dsply_cols
  )

  print_extras(extras_obj)
  invisible(x)
}

#' @noRd
records_msg <- function(obj) {
  x <- obj[[1L]]
  l <- list(nrec_dnld = obj[["dnld"]], nrec_avl = obj[["avl"]])
  nms <- names(l)

  for (i in seq_along(l)) {
    x_nm <- attr(x, nms[[i]])

    if (length(x_nm) > 0L) {
      suf <- paste0("Records ", l[[i]], ": ")
      x_nm <- paste(x_nm, collapse = " + ")
      n <- obj[["width"]] - nchar(suf) - 2L
      x_nm <- truncate_string(x_nm, n)
      cat(suf, x_nm, "\n", sep = "")
    }

  }
}

#' @noRd
format_cols <- function(obj) {
  df <- obj[["df"]]
  colname_widths <- obj[["colname_widths"]]

  for (i in seq_along(df)) {
    dfi <- df[[i]]
    class <- col_class(dfi)

    if (length(class) > 0L) {
      if (is.list(dfi)) {
        dfi_len <- lapply(dfi, length)
        dfi_na <- lapply(dfi, is.na)
        dfi_na <- lapply(dfi_na, sum)
        dfi <-  unlist(dfi_len) - unlist(dfi_na)
        suffix <- ifelse(dfi == 1L, "", "s")
        dfi <- paste0(dfi, " element", suffix)

      } else {
        if (identical(class, "uri")) {
          dfi <- truncate_string_to_unique(dfi)
        } else if (identical(class, "character")) {
          dfi <- truncate_string(dfi)
        } else {
          cwi <- colname_widths[[i]]
          dfi <- formatC(dfi,  cwi - 2L, cwi, flag = "- ")
        }
      }
    }

    df[[i]] <- dfi
  }

  df
}

#' @noRd
col_class <- function(x) {
  uris <- grepl("^http", x)

  if (any(uris)) {
    "uri"
  } else if (is.integer(x)) {
    "integer"
  } else if (is.numeric(x)) {
    "double"
  } else {
    "character"
  }

}

#' @noRd
print_extras <- function(obj) {
  extra_cols <- obj[["cols"]]
  extra_rows <- obj[["rows"]]
  no_cols <- extra_cols < 1L

  if (no_cols && extra_rows < 1L) {
    return(NULL)
  }

  suffix <- ""

  if (extra_rows > 1L) {
    suffix <- "s"
  }

  cat("...with ", extra_rows, " more record", suffix, sep = "")

  if (no_cols) {
    cat("\n")
    return(NULL)
  }

  suffix <- ""

  if (extra_cols > 1L) {
    suffix <- "s"
  }

  cat(" and ", extra_cols, " more variable", suffix, ":\n", sep = "")
  extra_names <- names(obj[[1L]])
  dsply_cols <- obj[["dc"]]
  extra_names <- extra_names[-dsply_cols]
  extra_name_i <- extra_names[[1L]]
  cat(extra_name_i)
  nchars <- nchar(extra_name_i) + 2L
  sq <- seq_along(extra_names)
  width <- getOption("width")

  for (i in sq[-1L]) {
    extra_name_i <- extra_names[[i]]
    nchars_next <- nchar(extra_name_i) + 2L
    nchars <- nchars + nchars_next
    sep <- ", "

    if (isTRUE(nchars > width)) {
      sep <- ",\n"
      nchars <- nchars_next
    }

    cat(sep, extra_name_i, sep = "")
  }

  cat("\n")
}