R/skeleton.R

In folkehelseinstituttet/fhidata: Structural Data for Norway

#' make_skeleton
#'
#' The easiest way to make structural data skeletons.
#' @param date_min The minimum date for the skeleton
#' @param date_max The maximum date for the skeleton
#' @param isoyearweek_min The minimum isoyearweek for the skeleton
#' @param isoyearweek_max The maximum isoyearweek for the skeleton
#' @param isoyear_min The minimum isoyear for the skeleton
#' @param isoyear_max The maximum isoyear for the skeleton
#' @param calyear_min The minimum calyear for the skeleton
#' @param calyear_max The maximum calyear for the skeleton
#' @param time_total Producing a 'total' time for the skeleton
#' @param location_code The location_code's wanted for the skeleton
#' @param granularity_geo The granularity_geo's wanted for the skeleton. If this is a list, then the returned value will also be in a list (see examples).
#' @param location_reference A data.table that contains two columns: location_code and granularity_geo
#' @param ... Other variables to include in the skeleton
#' @examples
#' make_skeleton(date_min="2020-01-01", date_max="2020-01-30", granularity_geo = c("nation", "county"))[]
#' make_skeleton(isoyearweek_min="2020-01", isoyearweek_max="2020-15", granularity_geo = c("nation", "county"))[]
#' make_skeleton(isoyear_min="2019", isoyear_max="2021", granularity_geo = c("nation", "county"))[]
#' make_skeleton(calyear_min="2019", calyear_max="2021", granularity_geo = c("nation", "county"))[]
#' make_skeleton(time_total = TRUE, granularity_geo = c("nation", "wardoslo"))[]
#' make_skeleton(time_total = TRUE, granularity_geo = list(c("wardoslo", "missingwardoslo"), c("county", "missingcounty", "notmainlandcounty"), "nation"))[]
#' make_skeleton(time_total = TRUE, granularity_geo = list("firstbatch" = c("wardoslo", "missingwardoslo"), c("county", "missingcounty", "notmainlandcounty"), "nation"))[]
#' make_skeleton(isoyearweek_min = "2020-01", isoyearweek_max = "2020-03", time_total = TRUE, granularity_geo = c("nation", "wardoslo"))[]
#' @export
make_skeleton <- function(
date_min = NULL,
date_max = NULL,
isoyearweek_min = NULL,
isoyearweek_max = NULL,
isoyear_min = NULL,
isoyear_max = NULL,
calyear_min = NULL,
calyear_max = NULL,
time_total = FALSE,
location_code = NULL,
granularity_geo = "all",
location_reference = fhidata::norway_locations_names(),
...
) {
  if(!is.null(location_code) | !is.list(granularity_geo)){
    return(
      make_skeleton_single(
        date_min = date_min,
        date_max = date_max,
        yrwk_min = isoyearweek_min,
        yrwk_max = isoyearweek_max,
        isoyear_min = isoyear_min,
        isoyear_max = isoyear_max,
        calyear_min = calyear_min,
        calyear_max = calyear_max,
        time_total = time_total,
        location_code = location_code,
        granularity_geo = granularity_geo,
        location_reference = location_reference,
        ...
      )
    )
  } else {
    retval <- vector("list", length=length(granularity_geo))
    for(i in seq_along(granularity_geo)){
      retval[[i]] <- make_skeleton_single(
        date_min = date_min,
        date_max = date_max,
        yrwk_min = isoyearweek_min,
        yrwk_max = isoyearweek_max,
        isoyear_min = isoyear_min,
        isoyear_max = isoyear_max,
        calyear_min = calyear_min,
        calyear_max = calyear_max,
        time_total = time_total,
        location_code = location_code,
        granularity_geo = granularity_geo[[i]],
        location_reference = location_reference,
        ...
      )
    }
    names(retval) <- unlist(lapply(granularity_geo, function(x) paste0(x, collapse="+")))
    if(!is.null(names(granularity_geo))){
      index <- which(names(granularity_geo) != "")
      names(retval)[index] <- names(granularity_geo)[index]
    }

    return(retval)
  }
}

make_skeleton_single <- function(
  date_min = NULL,
  date_max = NULL,
  yrwk_min = NULL,
  yrwk_max = NULL,
  isoyear_min = NULL,
  isoyear_max = NULL,
  calyear_min = NULL,
  calyear_max = NULL,
  time_total = FALSE,
  location_code = NULL,
  granularity_geo = "all",
  location_reference = fhidata::norway_locations_names(),
  ...
  ) {
  retval <- list()
  if (!is.null(date_min) & !is.null(date_max)) {
    retval[[length(retval)+1]] <- make_skeleton_date(
      date_min = date_min,
      date_max = date_max,
      location_code = location_code,
      granularity_geo = granularity_geo,
      location_reference = location_reference,
      ...
    )
  }
  if (!is.null(yrwk_min) & !is.null(yrwk_max)) {
    retval[[length(retval)+1]] <- make_skeleton_week(
      yrwk_min = yrwk_min,
      yrwk_max = yrwk_max,
      location_code = location_code,
      granularity_geo = granularity_geo,
      location_reference = location_reference,
      ...
    )
  }
  if (!is.null(isoyear_min) & !is.null(isoyear_max)) {
    retval[[length(retval)+1]] <- make_skeleton_year(
      year_min = isoyear_min,
      year_max = isoyear_max,
      location_code = location_code,
      granularity_geo = granularity_geo,
      location_reference = location_reference,
      ...
    )
    setnames(retval[[length(retval)]], "year", "isoyear")
    retval[[length(retval)]][, granularity_time := "isoyear"]
  }
  if (!is.null(calyear_min) & !is.null(calyear_max)) {
    retval[[length(retval)+1]] <- make_skeleton_year(
      year_min = calyear_min,
      year_max = calyear_max,
      location_code = location_code,
      granularity_geo = granularity_geo,
      location_reference = location_reference,
      ...
    )
    setnames(retval[[length(retval)]], "year", "calyear")
    retval[[length(retval)]][, granularity_time := "calyear"]
  }
  if (time_total == TRUE) {
    retval[[length(retval)+1]] <- make_skeleton_total(
      location_code = location_code,
      granularity_geo = granularity_geo,
      location_reference = location_reference,
      ...
    )
  }

  if(length(retval)==0){
    stop("must provide one of the following: 1) date pair, 2) yrwk pair, 3) time_total=T")
  } else {
    retval <- rbindlist(retval)
  }
  return(retval)
}

make_skeleton_date <- function(
  date_min = NULL,
  date_max = NULL,
  location_code = NULL,
  granularity_geo = "all",
  location_reference = fhidata::norway_locations_names(),
  ...) {
  dates <- seq.Date(
    from = as.Date(date_min),
    to = as.Date(date_max),
    by = 1
  )

  locs <- NULL
  if (!is.null(location_code)) {
    locs <- location_code
  } else if ("all" %in% granularity_geo) {
    locs <- location_reference$location_code
  } else {
    x_gran <- granularity_geo
    locs <- location_reference[granularity_geo %in% x_gran]$location_code
  }
  retval <- expand.grid(
    ...,
    date = dates,
    location_code = locs,
    stringsAsFactors = FALSE
  )
  setDT(retval)
  retval[, granularity_time := "day"]
  retval[, granularity_geo := fhidata::get_granularity_geo(location_code, location_reference = location_reference)]
  setcolorder(retval, c("granularity_time","date","granularity_geo","location_code"))
  setorderv(retval, names(retval))

  return(retval)
}

make_skeleton_week <- function(
  yrwk_min = NULL,
  yrwk_max = NULL,
  location_code = NULL,
  granularity_geo = "all",
  location_reference = fhidata::norway_locations_names(),
  ...) {
  if(yrwk_min==yrwk_max){
    yrwks <- yrwk_min
  } else {
    yrwk_min <- which(fhidata::world_dates_isoyearweek$yrwk==yrwk_min)
    yrwk_max <- which(fhidata::world_dates_isoyearweek$yrwk==yrwk_max)
    yrwks <- fhidata::world_dates_isoyearweek[yrwk_min:yrwk_max,yrwk]
  }

  locs <- NULL
  if (!is.null(location_code)) {
    locs <- location_code
  } else if ("all" %in% granularity_geo) {
    locs <- location_reference$location_code
  } else {
    x_gran <- granularity_geo
    locs <- location_reference[granularity_geo %in% x_gran]$location_code
  }
  retval <- expand.grid(
    ...,
    isoyearweek = yrwks,
    location_code = locs,
    stringsAsFactors = FALSE
  )
  setDT(retval)
  retval[, granularity_time := "isoweek"]
  retval[, granularity_geo := fhidata::get_granularity_geo(location_code, location_reference = location_reference)]
  setcolorder(retval, c("granularity_time","isoyearweek", "granularity_geo","location_code"))
  setorderv(retval, names(retval))
  return(retval)
}

make_skeleton_total <- function(
  location_code = NULL,
  granularity_geo = "all",
  location_reference = fhidata::norway_locations_names(),
  ...) {

  retval <- make_skeleton_week(
    yrwk_min = "1900-01",
    yrwk_max = "1900-01",
    location_code = location_code,
    granularity_geo = granularity_geo,
    location_reference = location_reference,
    ...
  )
  retval[, granularity_time := "total"]

  return(retval)
}

make_skeleton_year <- function(
  year_min = NULL,
  year_max = NULL,
  location_code = NULL,
  granularity_geo = "all",
  location_reference = fhidata::norway_locations_names(),
  ...) {

  retval <- make_skeleton_week(
    yrwk_min = paste0(year_min,"-01"),
    yrwk_max = paste0(year_max,"-01"),
    location_code = location_code,
    granularity_geo = granularity_geo,
    location_reference = location_reference,
    ...
  )
  retval[, year := as.numeric(stringr::str_extract(isoyearweek, "^[0-9][0-9][0-9][0-9]"))]
  retval[, isoyearweek := NULL]
  retval <- unique(retval)

  return(retval)
}