How do you adjust facet row label height in faceted tmap plots?

0

Issue

I am plotting faceted maps using the "tmap" package with rows and columns. I am unable to adjust the height of the facet labels for the rows which results in facet labels being cropped when they are bigger than a certain size or rotated.

I have tried adjusting all the tm_layout() arguments for panels including panel.label.height, panel.label.size and panel.label.rot. (using R 3.5.3, tmap_2.3 and tmaptools_2.0-2). Panel.label.height only seems to effect the panel height of the columns. I feel like I need something like panel.label.width to do the same for the label rows.

library(tmap);library(dplyr)

data(metro)

metro_edited <- metro %>% 
  mutate(pop1950cat = cut(pop1950, breaks=c(5, 10, 40)*1e6),
         pop2020cat = cut(pop2020, breaks=c(5, 10, 40)*1e6))


tm_shape(metro_edited) +
  tm_dots("red", size = .5) +
  tm_facets(c("pop1950cat", "pop2020cat"), 
            free.coords = FALSE)+ 
  tm_layout(panel.label.height=5, panel.label.size = 1, panel.label.rot = c(0,0))

enter image description here

I expect the panel label height of the row facets to also increase to 5 so that I can read the labels in the panels but they seem to be fixed and come out cropped as seen in the figure output.

Solution

There is a bug in the process_facet_layout function of tmap.
I modified it and now the width of the row facets are correctly calculated as for column facets.

library(tmap)
library(dplyr)
library(grid)

process_facet_layout <- function(gm) {
    panel.mode <- outer.margins <- attr.outside.position <- legend.outside.position <- NULL     
    fpi <- gm$shape.fpi

    if (gm$panel.mode=="none") {
        dh2 <- gm$shape.dh - fpi$legH - fpi$attrH - fpi$mainH - (gm$nrow - 1) * fpi$between.margin.in - fpi$xlabHin - gm$nrow * fpi$xgridHin
        dw2 <- gm$shape.dw - fpi$legW - (gm$ncol - 1) * fpi$between.margin.in - fpi$ylabWin - gm$ncol * fpi$ygridWin
    } else if (gm$panel.mode=="one") {
        dh2 <- gm$shape.dh - fpi$legH - fpi$attrH - fpi$mainH - gm$nrow * fpi$pSH - (gm$nrow - 1) * fpi$between.margin.in - fpi$xlabHin - gm$nrow * fpi$xgridHin
        dw2 <- gm$shape.dw - fpi$legW - (gm$ncol - 1) * fpi$between.margin.in - fpi$ylabWin - gm$ncol * fpi$ygridWin
    } else {
        dh2 <- gm$shape.dh - fpi$legH - fpi$attrH - fpi$mainH - fpi$pSH - fpi$between.margin.in * gm$nrow - fpi$xlabHin - gm$nrow * fpi$xgridHin
        dw2 <- gm$shape.dw - fpi$legW - fpi$pSW - fpi$between.margin.in * gm$ncol - fpi$ylabWin - gm$ncol * fpi$ygridWin+1
    }

    dasp2 <- dw2/dh2
    hasp <- gm$shape.sasp * gm$ncol / gm$nrow

    if (hasp>dasp2) {
        fW <- dw2
        fH <- dw2 / hasp
    } else {
        fH <- dh2
        fW <- dh2 * hasp
    }

    gasp <- fW/fH    
    if (gasp>dasp2) {
        xs <- 0
        ys <- convertHeight(unit(dh2-(dw2 / gasp), "inch"), "npc", valueOnly=TRUE)
    } else {
        xs <- convertWidth(unit(dw2-(gasp * dh2), "inch"), "npc", valueOnly=TRUE)
        ys <- 0
    }

    outerx <- sum(gm$outer.margins[c(2,4)])
    outery <- sum(gm$outer.margins[c(1,3)])     
    spc <- 1e-5 

    gm <- within(gm, {
        between.margin.y <- convertHeight(unit(fpi$between.margin.in, "inch"), "npc", valueOnly=TRUE)
        between.margin.x <- convertWidth(unit(fpi$between.margin.in, "inch"), "npc", valueOnly=TRUE)
        panelh <- convertHeight(unit(fpi$pSH, "inch"), "npc", valueOnly=TRUE)
        panelw <- convertWidth(unit(fpi$pSW, "inch"), "npc", valueOnly=TRUE)

        ylabWnpc <- convertWidth(unit(fpi$ylabWin, "inch"), "npc", valueOnly=TRUE)
        xlabHnpc <- convertHeight(unit(fpi$xlabHin, "inch"), "npc", valueOnly=TRUE)

        ygridWnpc <- convertWidth(unit(fpi$ygridWin, "inch"), "npc", valueOnly=TRUE)
        xgridHnpc <- convertHeight(unit(fpi$xgridHin, "inch"), "npc", valueOnly=TRUE)

        attr.between.legend.and.map <- attr.outside.position %in% c("top", "bottom")

        if (panel.mode=="none") {
            colrange <- (1:ncol)*3 + 3
            rowrange <- (1:nrow)*3 + 3
            facetw <- ((1-spc-outerx)-xs-fpi$legmarx-ylabWnpc-between.margin.x*(ncol-1))/ncol-ygridWnpc
            faceth <- ((1-spc-outery)-ys-fpi$legmary-fpi$attrmary-fpi$mainmary-xlabHnpc-between.margin.y*(nrow-1))/nrow-xgridHnpc
            colws <- c(outer.margins[2], xs/2, fpi$legmar[2], ylabWnpc, rep(c(ygridWnpc, facetw, between.margin.x), ncol-1), ygridWnpc, facetw, fpi$legmar[4], xs/2, outer.margins[4])

            if (attr.between.legend.and.map) {
                rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$legmar[3], fpi$attrmar[3], rep(c(faceth, xgridHnpc, between.margin.y), nrow-1), faceth, xgridHnpc, xlabHnpc, fpi$attrmar[1], fpi$legmar[1], ys/2, outer.margins[1])
            } else {
                rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$attrmar[3], fpi$legmar[3], rep(c(faceth, xgridHnpc, between.margin.y), nrow-1), faceth, xgridHnpc, xlabHnpc, fpi$legmar[1], fpi$attrmar[1], ys/2, outer.margins[1])
            }

        } else if (panel.mode=="one") {
            colrange <- (1:ncol)*3 + 3
            rowrange <- (1:nrow)*4 + 3

            facetw <- ((1-spc-outerx)-xs-fpi$legmarx-ylabWnpc-between.margin.x*(ncol-1))/ncol-ygridWnpc
            faceth <- ((1-spc-outery)-ys-fpi$legmary-fpi$attrmary-fpi$mainmary-xlabHnpc-between.margin.y*(nrow-1))/nrow - panelh-xgridHnpc

            colws <- c(outer.margins[2], xs/2, fpi$legmar[2], ylabWnpc, ygridWnpc, rep(c(facetw, between.margin.x, ygridWnpc), ncol-1), facetw, fpi$legmar[4], xs/2, outer.margins[4])
            if (attr.between.legend.and.map) {
                rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$legmar[3], fpi$attrmar[3], rep(c(panelh, faceth, xgridHnpc, between.margin.y), nrow-1), panelh, faceth, xgridHnpc, xlabHnpc, fpi$attrmar[1], fpi$legmar[1], ys/2, outer.margins[1])
            } else {
                rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$attrmar[3], fpi$legmar[3], rep(c(panelh, faceth, xgridHnpc, between.margin.y), nrow-1), panelh, faceth, xgridHnpc, xlabHnpc, fpi$legmar[1], fpi$attrmar[1], ys/2, outer.margins[1])
            }

        } else {
            colrange <- (1:ncol)*3 + 5
            rowrange <- (1:nrow)*3 + 5

            colpanelrow <- 6
            rowpanelcol <- 6 #5

            facetw <- ((1-spc-outerx)-xs-fpi$legmarx-ylabWnpc-between.margin.x*ncol-panelw)/ncol-ygridWnpc
            faceth <- ((1-spc-outery)-ys-fpi$legmary-fpi$attrmary-fpi$mainmary-xlabHnpc-between.margin.y*nrow-panelh)/nrow-xgridHnpc

            # Here is the modified code
            colws <- c(outer.margins[2], xs/2, fpi$legmar[2], ylabWnpc, panelw, c(panelw, ygridWnpc, facetw), rep(c(between.margin.x, ygridWnpc, facetw), ncol-1), fpi$legmar[4], xs/2, outer.margins[4])

            if (attr.between.legend.and.map) {
                rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$legmar[3], fpi$attrmar[3], panelh, rep(c(between.margin.y, faceth, xgridHnpc), nrow), xlabHnpc, fpi$attrmar[1],fpi$legmar[1], ys/2, outer.margins[1])
            } else {
                rowhs <- c(outer.margins[3], ys/2, fpi$mainmary, fpi$attrmar[3], fpi$legmar[3], panelh, rep(c(between.margin.y, faceth, xgridHnpc), nrow), xgridHnpc, xlabHnpc, fpi$legmar[1], fpi$attrmar[1], ys/2, outer.margins[1])
            }

        }
        if (legend.outside.position[1] == "left") {
            legx <- 3
            legy <- 5:(length(rowhs)-5)
        } else if (legend.outside.position[1] == "right") {
            legx <- length(colws)-2
            legy <- 5:(length(rowhs)-5)
        } else if (legend.outside.position[1] == "top") {
            legy <- 4- attr.between.legend.and.map
            legx <- 5:(length(colws)-3)
        } else if (legend.outside.position[1] == "bottom") {
            legy <- length(rowhs)-3 + attr.between.legend.and.map
            legx <- 5:(length(colws)-3)
        }

        if (tolower(attr.outside.position[1]) == "top") {
            attry <- 3 + attr.between.legend.and.map
            attrx <- 5:(length(colws)-3)
        } else {
            attry <- length(rowhs)-2 - attr.between.legend.and.map
            attrx <- 5:(length(colws)-3)
        }

        xlaby <- length(rowhs)-4
        xlabx <- 5:(length(colws)-3)

        ylaby <- 5:(length(rowhs)-5)
        ylabx <- 4

    })
    gm$gasp <- unname(gasp)
    gm
}
assignInNamespace(x="process_facet_layout", value=process_facet_layout, ns="tmap")

data(metro)
metro_edited <- metro %>% 
  mutate(pop1950cat = cut(pop1950, breaks=c(5, 10, 40)*1e6),
         pop2020cat = cut(pop2020, breaks=c(5, 10, 40)*1e6))

tm_shape(metro_edited) +
  tm_dots("red", size = .5) +
  tm_facets(c("pop1950cat", "pop2020cat"), free.coords=FALSE)+ 
  tm_layout(panel.label.height=1, panel.label.size=3, panel.label.rot = c(90,0))

enter image description here

Answered By – Marco Sandri

This Answer collected from stackoverflow, is licensed under cc by-sa 2.5 , cc by-sa 3.0 and cc by-sa 4.0

Leave A Reply

Your email address will not be published.

This website uses cookies to improve your experience. We'll assume you're ok with this, but you can opt-out if you wish. Accept Read More