R/pxweb_query.R

In pxweb: R Interface to PXWEB APIs

#' Create a PXWEB query
#'
#' @description 
#' Creates a pxweb query object from either a list with named values, 
#' a json query file or json query string. See examples below.
#'
#' @param x an object to cast as a pxweb_query object.
#' 
#' @seealso \code{\link{pxweb_query_as_json}}, \code{\link{pxweb_query_as_rcode}}
#' 
#' @examples 
#' dims <- list(Alue = c("*"),
#'              "Asuntokunnan koko" = c("*"),
#'              Talotyyppi = c("S"),
#'              Vuosi = c("*"))
#' pxq1 <- pxweb_query(dims)
#' 
#' json_query <- file.path(system.file(package = "pxweb"), 
#'                         "extdata", "examples", "json_query_example.json")
#' pxq2 <- pxweb_query(json_query)
#' 
#' 
#' @export
pxweb_query <- function(x){
  UseMethod("pxweb_query")
}

#' @rdname pxweb_query
#' @keywords internal
#' @export
pxweb_query.character <- function(x){
  obj <- jsonlite::fromJSON(x, simplifyDataFrame = FALSE)
  if(is.character(obj)){
    stop("jsonlite::fromJSON() cannot parse the PXWEB (JSON) query. Please check your (JSON) query.", call. = FALSE)
  }
  class(obj) <- c("pxweb_query", "list")
  assert_pxweb_query(obj, check_response_format = FALSE)
  if(tolower(obj$response$format) == "json"){
    obj$response$format <- "json"
  } else if (tolower(obj$response$format) %in% c("json-stat", "jsonstat")){
    obj$response$format <- "json-stat"    
  } else if (tolower(obj$response$format) %in% pxweb_file_response_formats()){

  } else {
    warning(paste0("'", obj$response$format, "' is not a valid query response format, set to 'json'."))
    obj$response$format <- "json"
  }
  assert_pxweb_query(obj)
  obj
}

pxweb_file_response_formats <- function() c("px", "sdmx")

#' @rdname pxweb_query
#' @keywords internal
#' @export
pxweb_query.json <- function(x){
  pxweb_query(x = as.character(x))
}

#' @rdname pxweb_query
#' @keywords internal
#' @export
pxweb_query.pxweb_query <- function(x){
  return(x)
}

#' @rdname pxweb_query
#' @keywords internal
#' @export
pxweb_query.list <- function(x){
  checkmate::assert_named(x)
  obj <- list(query = list(),
              response = list(format = "json"))
  for(i in seq_along(x)){
    obj$query[[i]] <- list(code = names(x)[i],
                           selection = list(filter = "item",
                                            values = x[[i]]))
    if(x[[i]][1] == "*") {
      obj$query[[i]]$selection$filter <- "all"
    }
  }
  class(obj) <- c("pxweb_query", "list")
  assert_pxweb_query(obj)
  obj
}

#' @rdname pxweb_query
#' @keywords internal
#' @export
pxweb_query.response <- function(x){
  if(is.null(x$request$options$postfields)) return(NULL)
  pxweb_query(x = readBin(x$request$options$postfields, what = "character"))
}


#' @rdname pxweb_query
#' @keywords internal
#' @export
pxweb_query.pxweb_explorer <- function(x){
  checkmate::assert_true(pxe_position_is_full_query(x))
  md_ch <- pxe_metadata_choices(x)
  mdo <- pxe_pxobj_at_position(x)
  mdo_vnm <- pxweb_metadata_dim(mdo)
  
  obj <- list()
  for(i in seq_along(mdo$variables)){
    var_nm <- mdo$variables[[i]]$code
    if(md_ch[[var_nm]][1] == "eliminate"){
      next
    }
    obj[[var_nm]] <- mdo$variables[[i]]$values[md_ch[[var_nm]]]
  }
  pxq <- pxweb_query(obj)
  pxweb_validate_query_with_metadata(pxq, mdo)
  pxq
}

#' Assert a pxweb_query object
#' 
#' @param x an object to assert conferms to the structure of an pxweb_query object.
#' 
#' @keywords internal
assert_pxweb_query <- function(x, check_response_format = TRUE){
  checkmate::assert_class(x, c("pxweb_query", "list"), .var.name = "pxweb_query")
  checkmate::assert_names(names(x), must.include = c("query", "response"), .var.name = "names(pxweb_query)")
  checkmate::assert_names(names(x$response), must.include = c("format"))
  if(check_response_format){
    checkmate::assert_choice(x$response$format, c("json", "json-stat", pxweb_file_response_formats()))
  }
  

  checkmate::assert_named(x$query, "unnamed")
  for(i in seq_along(x$query)){
    checkmate::assert_character(x$query[[i]]$code, any.missing = FALSE, min.len = 1)
    checkmate::assert_names(names(x$query[[i]]$selection), must.include = c("filter", "values"))
    checkmate::assert_character(x$query[[i]]$selection$filter, len = 1, any.missing = FALSE)
    checkmate::assert_character(x$query[[i]]$selection$values)
    checkmate::assert_named(x$query[[i]]$selection$values, type = "unnamed")
  }
  
  # Assert filter values
  for(i in seq_along(x$query)){
    filter_aggr <- FALSE
    if(grepl(x = x$query[[i]]$selection$filter, "^[Vv]s:.*")){
      filter_aggr <- TRUE
    }
    if(grepl(x = x$query[[i]]$selection$filter, "^[Aa]gg:.*")){
      filter_aggr <- TRUE
    }
    if(!filter_aggr) {
      checkmate::assert_choice(x$query[[i]]$selection$filter, choices = c("item", "all", "top", "agg:[aggregated values]", "vs:[other value set]"))
      if(x$query[[i]]$selection$filter %in% c("all", "top")){
        checkmate::assert_character(x$query[[i]]$selection$values, len = 1, .var.name = paste0("x$query[[", i, "]]$selection$values"))
      }
    }
  }
}



#' @export
print.pxweb_query <- function(x, ...){
  cat("PXWEB QUERY\n")
  cat("query:\n")
  for(i in seq_along(x$query)){
    cat(" [[", i ,"]] ",  x$query[[i]]$code," (", x$query[[i]]$selection$filter, "):\n", sep = "")
    cat("   ", paste(x$query[[i]]$selection$values, collapse = ", "), "\n", sep = "")    
  }
  if(x$response$format == "json-stat"){
    cat("return: json-stat\n")
  }
}



#' Validate a \code{pxweb_query} with a \code{pxweb_metadata} object
#' 
#' @details 
#' Validate a query with a metadata object to asses that the query can be used to 
#' query the table.
#' 
#' @param pxq a \code{pxweb_query} object.
#' @param pxmd a \code{pxweb_metadata} object.
#' 
#' @examples 
#' \dontrun{
#' url <- "https://api.scb.se/OV0104/v1/doris/sv/ssd/BE/BE0101/BE0101A/BefolkningNy"
#' json_query <- file.path(system.file(package = "pxweb"), 
#'                         "extdata", "examples", "json_query_example.json")
#' pxq <- pxweb_query(json_query)
#' pxweb_validate_query_with_metadata(pxq, pxweb_get(url))
#' }
#' 
#' @export
pxweb_validate_query_with_metadata <- function(pxq, pxmd){
  checkmate::assert_class(pxq, "pxweb_query")
  checkmate::assert_class(pxmd, "pxweb_metadata")
  
  pxweb_metadata_variables <- unlist(lapply(pxmd$variables, function(x) x$code))
  query_variables <- character(length(pxq$query))
  for(i in seq_along(pxq$query)){
    query_variables[i] <- pxq$query[[i]]$code
    pxweb_query_variable_code <- pxq$query[[i]]$code
    checkmate::assert_choice(pxweb_query_variable_code, choices = pxweb_metadata_variables)
    if(tolower(pxq$query[[i]]$selection$filter) == "item"){
      pxweb_query_variable_values <- pxq$query[[i]]$selection$values
      meta_idx <- which(pxweb_metadata_variables %in% pxweb_query_variable_code)
      pxweb_metadata_variable_values <- pxmd$variables[[meta_idx]]$values
      if(!is.null(pxweb_metadata_variable_values)){
        checkmate::assert_subset(pxweb_query_variable_values, choices = pxweb_metadata_variable_values, .var.name = pxq$query[[i]]$code)
      }
    }
  }
  mandatory_variables <- character(0)
  for(i in seq_along(pxmd$variables)){
    if(!pxmd$variables[[i]]$elimination){
      mandatory_variables <- c(mandatory_variables, pxmd$variables[[i]]$code)
    }
  }
  if(!all(mandatory_variables %in% query_variables)){
    mandatory_variables_missing <- mandatory_variables[!mandatory_variables %in% query_variables]
    stop("Mandatory variable(s) '", paste0(mandatory_variables_missing, collapse = "', '"), "' is missing in the query.", call. = FALSE)
  }
}


#' Add and remove metadata to query
#' 
#' @details 
#' Add metadata values to variables with a query with filter "all".
#' 
#' @param pxq a \code{pxweb_query} object.
#' @param pxmd a \code{pxweb_metadata} object.
#' 
#' @keywords internal
pxweb_add_metadata_to_query <- function(pxq, pxmd){
  checkmate::assert_class(pxq, "pxweb_query")
  checkmate::assert_class(pxmd, "pxweb_metadata")

  # Set values to filter "all"
  pxweb_metadata_variables <- unlist(lapply(pxmd$variables, function(x) x$code))
  for(i in seq_along(pxq$query)){
    pxweb_query_variable_code <- pxq$query[[i]]$code
    checkmate::assert_choice(pxweb_query_variable_code, choices = pxweb_metadata_variables)
    if(tolower(pxq$query[[i]]$selection$filter) == "all"){
      px_pattern <- pxq$query[[i]]$selection$values
      px_pattern <- paste0("^", gsub(pattern = "\\*", replacement = "\\.\\+", px_pattern))
      meta_data_values <- pxmd$variables[[which(pxweb_metadata_variables %in% pxweb_query_variable_code)]]$values
      if(!is.null(meta_data_values)){
        meta_data_values <- meta_data_values[grepl(x = meta_data_values, pattern = px_pattern)]
        pxq$query[[i]]$selection$values <- meta_data_values
        pxq$query[[i]]$selection$filter <- "item"
      }
    }
  }
  
  assert_pxweb_query(pxq)
  pxq
}

#' @rdname pxweb_add_metadata_to_query
#' @keywords internal
pxweb_remove_metadata_from_query  <- function(pxq, pxmd){
  checkmate::assert_class(pxq, "pxweb_query")
  checkmate::assert_class(pxmd, "pxweb_metadata")

  # set full queries to all *
  pxweb_metadata_variables <- unlist(lapply(pxmd$variables, function(x) x$code))
  for(i in seq_along(pxq$query)){
    query_size <-length(pxq$query[[i]]$selection$values)
    pxweb_query_variable_code <- pxq$query[[i]]$code
    meta_data_size <- length(pxmd$variables[[which(pxweb_metadata_variables %in% pxweb_query_variable_code)]]$values)
    if(query_size >= meta_data_size & query_size > 1){
      pxq$query[[i]]$selection$filter <- "all"
      pxq$query[[i]]$selection$values <- "*"
    }
  }
  assert_pxweb_query(pxq)
  pxq  
}

#' Compue the dimension of the query
#' 
#' @param pxq a \code{pxweb_query} object.
#' 
#' @keywords internal
pxweb_query_dim <- function(pxq){
  checkmate::assert_class(pxq, "pxweb_query")
  dim_res <- numeric(length(pxq$query))
  for(i in seq_along(pxq$query)){
    names(dim_res)[i] <- pxq$query[[i]]$code
    if(tolower(pxq$query[[i]]$selection$filter) == "top"){
      dim_res[i] <- as.numeric(pxq$query[[i]]$selection$values)
    } else if(tolower(pxq$query[[i]]$selection$filter) == "all"){
      warning("Cannot compute the dimension for a variable with filter 'all', set to 1.", call. = FALSE)
      dim_res[i] <- 1
    } else {
      dim_res[i] <- length(pxq$query[[i]]$selection$values)
    }
  }
  dim_res
}


#' Get query filter
#' 
#' @param pxq a \code{pxweb_query} object.
#' 
#' @return query variable selection values as a named list of character vectors.
#' 
#' @keywords internal
pxweb_query_values <- function(pxq){
  checkmate::assert_class(pxq, "pxweb_query")
  res <- lapply(pxq$query,function(x) x$selection$values)   
  names(res) <- unlist(lapply(pxq$query,function(x) x$code))   
  res
}


#' Get query values
#' 
#' @param pxq a \code{pxweb_query} object.
#' 
#' @return query variable selection filters as a named character vector.
#' 
#' @keywords internal
pxweb_query_filter <- function(pxq){
  checkmate::assert_class(pxq, "pxweb_query")
  res <- unlist(lapply(pxq$query,function(x) x$selection$filter)) 
  names(res) <- unlist(lapply(pxq$query,function(x) x$code))   
  res
}


#' Convert a \code{pxweb_query} object to a \code{json} string
#' 
#' @param pxq a \code{pxweb_query} object.
#' @param ... further argument to \code{jsonlite::toJSON()}.
#' 
#' @seealso \code{\link{pxweb_query}}, \code{\link{pxweb_query_as_rcode}}
#' 
#' @examples 
#' json_query <- file.path(system.file(package = "pxweb"), 
#'                         "extdata", "examples", "json_query_example.json")
#' pxq <- pxweb_query(json_query)
#' json <- pxweb_query_as_json(pxq, pretty = TRUE)
#' 
#' @export
pxweb_query_as_json <- function(pxq, ...){
  checkmate::assert_class(pxq, "pxweb_query")
  pxq$response$format <- jsonlite::unbox(pxq$response$format)
  for(i in seq_along(pxq$query)){
    pxq$query[[i]]$code <- jsonlite::unbox(pxq$query[[i]]$code)
    pxq$query[[i]]$selection$filter <- jsonlite::unbox(pxq$query[[i]]$selection$filter)
  }
  jsonlite::toJSON(pxq, ...)
}

#' Print a \code{pxweb_query} object as R code
#' 
#' @param pxq a \code{pxweb_query} object.
#' 
#' @seealso \code{\link{pxweb_query_as_json}}, \code{\link{pxweb_query}}
#' 
#' @export
pxweb_query_as_rcode <- function(pxq){
  checkmate::assert_class(pxq, "pxweb_query")
  
  res <- character(length(pxq$query))
  for(i in seq_along(pxq$query)){
    res[i] <- paste0("\"", pxq$query[[i]]$code, "\"=c(", paste(paste0("\"", pxq$query[[i]]$selection$values, "\""), collapse = ","), ")")
    if(i == 1){
      res[i] <- paste0("  list(", res[i])
    } else {
      res[i] <- paste0("       ", res[i])
    }
  }
  res[length(res)] <- paste0(res[length(res)], ")")
  if(length(res) > 1){
    res[-length(res)] <- paste0(res[-length(res)], ",")
  }
  res <- c("pxweb_query_list <- ", res)
  cat(res, sep ="\n")
  invisible(res)
}