R/mappingDE.R

In mapping: Automatic Download, Linking, Manipulating Coordinates for Maps

mappingDE <- function(data, var = NULL, colID = NULL,
                      type = c("static", "interactive"),
                      typeStatic = c("tmap", "choro.cart", "typo", "bar"),
                      unit = c("state","district", "municipal", "municipality"),
                      matchWith = c("name", "code", "code_full"), dir = NULL,
                      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(mappingUK)$type))
  typeStatic <- match.arg(typeStatic, choices = eval(formals(mappingUK)$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, "DE"))
  {
    # if(is.null(year))
    # {
    #   stop("year must be provided.")
    # }
    data <- data.frame(data, check.names = FALSE)
    
    unit <- match.arg(unit, choices = eval(formals(mappingDE)$unit))
    matchWith <- match.arg(matchWith, choices = eval(formals(mappingDE)$matchWith))
    
    data <- DE(data = data, colID = colID, unit = unit, matchWith = matchWith, subset = subset,
               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
    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("state","district", "municipal", "municipality")))
      {
        unit <- aggregation_unit
        nm <- getNamesDE(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),"DE")
          
          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] <- stri_trans_tolower(data[,aggregation_unit, drop = TRUE])
        nm[,aggregation_unit] <- as.character(stri_trans_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)
    # }
    
  }
  
  
}