qgis_style.R

#' A qml create function
#'
#' This function creates QGIS-like xml object with random colors based on a group variable
#' @param obj an object of class SpatialPolygonDataFrame or data.frame
#' @param group a grouping variable (colname from obj)
#' @param alpha an alpha value (0-1)
#' @param colors a character vector with colors (hex colors)
#'
#' @return xml object
#'
#' @import XML
#' @importFrom purrr %>% map
#' @importClassesFrom sp SpatialPolygonsDataFrame
#' @importFrom grDevices colorRampPalette
#'
#' @export
#'
#' @examples
#' \dontrun{
#' qml_object <- qml_create(shapefile_obj, 'group')
#' saveXML(qml_object, file='new_file.qml')}
#' 

library(XML)
library(tidyverse)
library(sp)
library(sf)

qml_create <- function (obj, group, alpha = 1, colors = NULL) {
        if (class(obj) == "SpatialPolygonsDataFrame") {
                df <- obj@data
        } else {
                df <- obj %>% as.data.frame()
        }
        if (!missing(colors)) {
                df$v <- colors
        } else {
                df <- rgb_add(df, group)
        }
        if (is.factor(df[, group])){
                df[, group] <- as.character(df[, group])
        }
        attribute <- group
        base <- newXMLNode("qgis")
        addAttributes(base, version = "2.14.3-Essen", minimumScale = "0",
                      maximumScale = "1e+08", simplifyDrawingHints = "1", minLabelScale = "0",
                      maxLabelScale = "1e+08", simplifyDrawingTol = "1", simplifyMaxScale = "1",
                      hasScaleBasedVisibilityFlag = "0", simplifyLocal = "1",
                      scaleBasedLabelVisibilityFlag = "0")
        trans <- newXMLNode("transparencyLevelInt", 255)
        rend <- newXMLNode("renderer-v2", attrs = c(attr = attribute,
                                                    symbollevels = "0", type = "categorizedSymbol"))
        categories <- newXMLNode("categories")
        category <- seq_along(unique(df[, group])) %>% map(~category_node(.,
                                                                  df = df, group = group))
        addChildren(categories, category)
        symbols <- newXMLNode("symbols")
        symbol <- seq_along(unique(df[, group])) %>% map(~symbol_node(.,
                                                              df = df, alpha = alpha))
        addChildren(symbols, symbol)
        addChildren(rend, list(categories, symbols))
        addChildren(base, list(trans, rend))
        base
}

rand_rgb <- function(){
        paste(paste(sample(1:255, 3, replace=TRUE), collapse=","), "255", sep=",")
}

rgb_add <- function(df, group){
        colors <- replicate(length(unique(df[, group])), rand_rgb())
        df$v <- colors
        df
}

category_node <- function(x, df, group){
        newXMLNode("category", attrs = c(symbol = as.character(x-1), value = df[, group][x], label = df[, group][x]))
}

symbol_node <- function(x, df, alpha){
        dum_sym <- newXMLNode("symbol", attrs = c(outputUnit="MM", alpha=alpha, type="fill", name=as.character(x-1)))
        layer <- newXMLNode("layer", attrs = c(pass="0", class="SimpleFill", locked="0"))
        prop <- newXMLNode("prop", attrs = c(k="color", v=df[, 'v'][x]))
        addChildren(layer, prop)
        addChildren(dum_sym, layer)
}


nc = st_read(system.file("shape/nc.shp", package="sf")) %>% 
        mutate(my_group = as.factor(rep(c("low", "medium", "high", "unknown"), 25)))

nc_sp = as(nc, "Spatial")

qml_object = qml_create(nc, 'my_group')

st_write(nc, "nc.gpkg")
saveXML(qml_object, file='nc.qml')