tests/testthat/test-vignette_10.R

In rolap: Obtaining Star Databases from Flat Tables

test_that("rpd", {
  #############################################################

  ## ----------------------------------------------------------------------------------------------------------
  when <- dimension_schema(name = "When",
                           attributes = c("Year",
                                          "WEEK",
                                          "Week Ending Date"))
  when_available <- dimension_schema(
    name = "When Available",
    attributes = c(
      "Data Availability Year",
      "Data Availability Week",
      "Data Availability Date"
    )
  )
  where <- dimension_schema(name = "where",
                            attributes = c("REGION",
                                           "State",
                                           "City"))
  s <- star_schema() |>
    define_facts(fact_schema(
      name = "MRS Cause",
      measures = c("Pneumonia and Influenza Deaths",
                   "All Deaths")
    )) |>
    define_dimension(when) |>
    define_dimension(when_available) |>
    define_dimension(dimension_schema(
      name = "When Received",
      attributes = c("Reception Year",
                     "Reception Week",
                     "Reception Date")
    )) |>
    define_dimension(where)


  ## ----------------------------------------------------------------------------------------------------------
  db <- star_database(s, ft_cause_rpd) |>
    snake_case()


  ## ----------------------------------------------------------------------------------------------------------
  db_1 <- db |>
    role_playing_dimension(
      rpd = "when",
      roles = c("when_available", "when_received")
    )


  ## ----------------------------------------------------------------------------------------------------------
  db_2 <- db |>
    role_playing_dimension(
      rpd = "when",
      roles = c("when_available", "when_received"),
      rpd_att_names = TRUE
    )


  ## ----------------------------------------------------------------------------------------------------------
  s_2 <- star_schema() |>
    define_facts(fact_schema(
      name = "MRS Age",
      measures = c(
        "Deaths"
      )
    )) |>
    define_dimension(when) |>
    define_dimension(when_available) |>
    define_dimension(dimension_schema(
      name = "When Arrived",
      attributes = c(
        "Arrival Year",
        "Arrival Week",
        "Arrival Date"
      )
    )) |>
    define_dimension(dimension_schema(
      name = "Who",
      attributes = c(
        "Age Range"
      )
    )) |>
    define_dimension(where)


  ## ----------------------------------------------------------------------------------------------------------
  db_3 <- star_database(s_2, ft_age_rpd) |>
    role_playing_dimension(
      rpd = "When Arrived",
      roles = c("When Available"),
      att_names = c("Year", "Week", "Week Ending Date")
    ) |>
    snake_case()


  ## ----------------------------------------------------------------------------------------------------------
  ct <- constellation("MRS", db_2, db_3)


  ## ----------------------------------------------------------------------------------------------------------
  rpd_names <- ct  |>
    get_role_playing_dimension_names()

  names <- names(ct$dimensions$when$table)


  #############################################################
  expect_equal({
    rpd_names
  },
  {
    list(rpd_1 = c("when", "when_arrived", "when_available", "when_received"))
  })



  #############################################################
  expect_equal({
    ct$dimensions$when$table
  },
  {
    d2 <- ct$dimensions$when_arrived$table
    names(d2) <- names
    d2
  })



  #############################################################
  expect_equal({
    ct$dimensions$when$table
  },
  {
    d2 <- ct$dimensions$when_available$table
    names(d2) <- names
    d2
  })



  #############################################################
  expect_equal({
    ct$dimensions$when$table
  },
  {
    d2 <- ct$dimensions$when_received$table
    names(d2) <- names
    d2
  })


  #############################################################
})