R/mappingIT.R

Defines functions mappingIT

Documented in mappingIT

mappingIT <- function(data, var = NULL, colID = NULL,
                      type = c("static", "interactive"),
                      typeStatic = c("tmap", "choro.cart", "typo", "bar"),
                      unit = c("none","ripartizione", "regione", "provincia", "comune"),
                      year = c("2021","2020","2019", "2018", "2017"),
                      matchWith = c("name", "code","number"), dir = NULL,
                      show_it = TRUE, add_text = NULL, subset = NULL,
                      facets = NULL, aggregation_fun = sum, aggregation_unit = NULL,
                      options = mapping.options())

{
  check.unit.names = options$check.unit.names
  use_cache = options$use_cache
  use_internet = options$use_internet
  type <- match.arg(type, choices = eval(formals(mappingIT)$type))
  typeStatic <- match.arg(typeStatic, choices = eval(formals(mappingIT)$typeStatic))


  if(!is.null(var))
  {
    if(is.numeric(var))
    {
      var <- colnames(data)[var]

    }else{
      if(!any(sapply(var, function(x) x == colnames(data))))
      {
        stop("Column names var does not exist.", call. = FALSE)
      }
    }
  }


  if(!inherits(data, "IT"))
  {
    # if(is.null(year))
    # {
    #   stop("year must be provided.")
    # }
    data <- data.frame(data, check.names = FALSE)

    unit <- match.arg(unit, choices = eval(formals(mappingIT)$unit))
    year <- match.arg(year, choices = eval(formals(mappingIT)$year))
    matchWith <- match.arg(matchWith, choices = eval(formals(mappingIT)$matchWith))

    data <- IT(data = data, colID = colID, unit = unit, matchWith = matchWith, subset = subset, show_it = show_it,
               year = year, check.unit.names = check.unit.names, use_cache = use_cache, use_internet = use_internet, crs = options$crs,
               aggregation_fun = aggregation_fun, aggregation_unit = aggregation_unit, aggregation_var = var, dir = dir)

    colID <- attributes(data)$colID

  }else
  {

    unit <- attributes(data)$unit
    year <- attributes(data)$year
    colID <- attributes(data)$colID

    if(!is.null(subset))
    {
      if(!inherits(subset, "formula"))
      {
        stop("subset must be a formula.")
      }
      #data <- data[data[[unitubset]] %in% subset,]
      data <- subset_formula(data = data, formula = subset)
    }


    if(!is.null(aggregation_unit))
    {

      if(is.null(aggregation_fun))
      {
        stop("aggregation_fun must be provided to aggregate data")
      }


      #data <- st_buffer(data, 0)

      if(any(aggregation_unit%in%c("none","ripartizione", "regione", "provincia", "comune")))
        {
        unit <- aggregation_unit
        nm <- getNamesIT(year = year, unit = unit, all_levels = TRUE)
        if(attributes(data)$unit == aggregation_unit)
        {
          colnames(nm)[which(colnames(nm) == aggregation_unit)] <- attributes(data)$colID
          aggregation_unit <- attributes(data)$colID
        }


        if(is.null(facets)| isTRUE(facets == aggregation_unit))
        {
          data <- aggregate(x = data[,var],
                            by = list(var = data[, aggregation_unit, drop = TRUE]), FUN = aggregation_fun)

          colnames(data)[1] <- aggregation_unit
          facets_join <- NULL
          # data[,aggregation_unit] <- tolower(data[,aggregation_unit, drop = TRUE])
          # nm[,aggregation_unit] <- as.character(tolower(nm[,aggregation_unit, drop = TRUE]))
          # data[,aggregation_unit] = as.character(data[,aggregation_unit, drop = TRUE])
          # data <- suppressWarnings(left_join(data, nm, aggregation_unit))

        }else{

          if(!any(facets %in% colnames(data)))
          {
            stop("facets name does not exit.")
          }

          dt <- lapply(levels(factor(data[,facets, drop = TRUE])), function(x) aggregate(x = data[data[,facets, drop = TRUE]==x, var],
                                                                                         by = list(var = data[data[,facets, drop = TRUE]==x,aggregation_unit, drop = TRUE],
                                                                                                   var2 = data[data[,facets, drop = TRUE]==x,facets, drop = TRUE]),
                                                                                         FUN = aggregation_fun))

          data <- do.call("rbind", dt)
          class(data) <- c(class(data),"IT")

          colnames(data)[1] <- aggregation_unit

          if(any(facets %in% colnames(nm)))
          {
            facets <- paste(facets,"_facets", sep = "")
          }

          colnames(data)[2] <- facets
          facets_join <- facets

        }

        data[,aggregation_unit] <- tolower(data[,aggregation_unit, drop = TRUE])
        nm[,aggregation_unit] <- as.character(tolower(nm[,aggregation_unit, drop = TRUE]))
        data[,aggregation_unit] = as.character(data[,aggregation_unit, drop = TRUE])
        data <- suppressWarnings(left_join(data, nm,c(aggregation_unit)))


      }else{

        if(is.null(facets)| isTRUE(facets == aggregation_unit))
        {
          data <- aggregate(x = data[,var],
                            by = list(var = data[, aggregation_unit, drop = TRUE]), FUN = aggregation_fun)
          colnames(data)[1] <- aggregation_unit

        }else{
          dt <- lapply(levels(factor(data[,facets, drop = TRUE])), function(x) aggregate(x = data[data[,facets, drop = TRUE]==x, var],
                                                                                         by = list(var = data[data[,facets, drop = TRUE]==x,aggregation_unit, drop = TRUE],
                                                                                                   var2 = data[data[,facets, drop = TRUE]==x,facets, drop = TRUE]),
                                                                                         FUN = aggregation_fun))

          data <- do.call("rbind", dt)

          colnames(data)[1] <- aggregation_unit
          colnames(data)[2] <- facets
        }

      }

      colID <- aggregation_unit

    }

    # attributes(data)$unit <- unit
    # attributes(data)$colID <- colID
  }





  if(type == "static")
  {

    if(typeStatic == "tmap")
    {

      mapping_tmap(data, var = var,
                   facets = facets, add_text = add_text,
                   options = options)

    }else if(typeStatic == "choro.cart")
    {
      mapping_choro(data = data, var = var, options = options)

    }else if(typeStatic == "typo")
    {

      mapping_typo(data = data, var = var, options = options)

    }else if(typeStatic == "bar")
    {

      mapping_bar(data = data, var = var, options = options)

    }

  }else if(type == "interactive"){
    if(!is.null(facets))
    {


      if(isFALSE(options$facets.free.scale))
      {
        plot_interactive_choro_facetes(data = data,
                                       var = var,
                                       colID = colID,
                                       facets = facets,
                                       options = options)
      }else{
        plot_interactive_choro_facetes_freeScale(data = data,
                                                 var = var,
                                                 colID = colID,
                                                 facets = facets,
                                                 options = options)
      }

    }else{

      plot_interactive_choro(data = data,
                             var = var,
                             colID = colID,
                             options = options)
    }




    # if(type == "tmap")
    # {
    #
    #   mapping_tmap_interactive(data = data, var = var, colID = colID, options = options, add_text = add_text)
    #
    # }else if(type == "mapview")
    # {
    #   mapping_mapview(data = data, var = var, colID = colID, options = options)
    # }

  }


}

Try the mapping package in your browser

Any scripts or data that you put into this service are public.

mapping documentation built on Oct. 19, 2023, 5:06 p.m.