1
#' Plot a fitted scaling model
2
#'
3
#' Plot the results of a fitted scaling model, from (e.g.) a predicted
4
#' [textmodel_wordscores] model or a fitted [textmodel_wordfish]
5
#' or [textmodel_ca]
6
#' model. Either document or feature parameters may be plotted: an ideal
7
#' point-style plot (estimated document position plus confidence interval on the
8
#' x-axis, document labels on the y-axis) with optional renaming and sorting, or
9
#' as a plot of estimated feature-level parameters (estimated feature positions
10
#' on the x-axis, and a measure of relative frequency or influence on the
11
#' y-axis, with feature names replacing plotting points with some being chosen
12
#' by the user to be highlighted).
13
#' @param x the fitted or predicted scaling model object to be plotted
14
#' @param margin `"documents"` to plot estimated document scores (the
15
#'   default) or `"features"` to plot estimated feature scores by a measure
16
#'   of relative frequency
17
#' @param sort if `TRUE` (the default), order points from low to high
18
#'   score. If a vector, order according to these values from low to high. Only
19
#'   applies when `margin = "documents"`.
20
#' @inheritParams quanteda::groups
21
#' @param doclabels a vector of names for document; if left NULL (the default),
22
#'   docnames will be used
23
#' @param highlighted a vector of feature names to draw attention to in a
24
#'   feature plot; only applies if `margin = "features"`
25
#' @param highlighted_color color for highlighted terms in `highlighted`
26
#' @param alpha A number between 0 and 1 (default 0.5) representing the level of
27
#'   alpha transparency used to overplot feature names in a feature plot; only
28
#'   applies if `margin = "features"`
29
#' @return a \pkg{ggplot2} object
30
#' @note The `groups` argument only applies when `margin = "documents"`.
31
#' @export
32
#' @author Kenneth Benoit, Stefan Müller, and Adam Obeng
33
#' @seealso [textmodel_wordfish()], [textmodel_wordscores()],
34
#'   [textmodel_ca()]
35
#' @keywords textplot
36
#' @examples
37
#' \dontrun{
38
#' dfmat <- quanteda::dfm(data_corpus_irishbudget2010)
39
#'
40
#' ## wordscores
41
#' refscores <- c(rep(NA, 4), 1, -1, rep(NA, 8))
42
#' tmod1 <- textmodel_wordscores(dfmat, y = refscores, smooth = 1)
43
#' # plot estimated document positions
44
#' textplot_scale1d(predict(tmod1, se.fit = TRUE),
45
#'                  groups = docvars(data_corpus_irishbudget2010, "party"))
46
#' # plot estimated word positions
47
#' textplot_scale1d(tmod1, highlighted = c("minister", "have", "our", "budget"))
48
#'
49
#' ## wordfish
50
#' tmod2 <- textmodel_wordfish(dfmat, dir = c(6,5))
51
#' # plot estimated document positions
52
#' textplot_scale1d(tmod2)
53
#' textplot_scale1d(tmod2, groups = docvars(data_corpus_irishbudget2010, "party"))
54
#' # plot estimated word positions
55
#' textplot_scale1d(tmod2, margin = "features",
56
#'                  highlighted = c("government", "global", "children",
57
#'                                  "bank", "economy", "the", "citizenship",
58
#'                                  "productivity", "deficit"))
59
#'
60
#' ## correspondence analysis
61
#' tmod3 <- textmodel_ca(dfmat)
62
#' # plot estimated document positions
63
#' textplot_scale1d(tmod3, margin = "documents",
64
#'                  groups = docvars(data_corpus_irishbudget2010, "party"))
65
#' }
66
textplot_scale1d <- function(x,
67
                             margin = c("documents", "features"),
68
                             doclabels = NULL,
69
                             sort = TRUE, groups = NULL,
70
                             highlighted = NULL, alpha = 0.7,
71
                             highlighted_color = "black") {
72 1
    UseMethod("textplot_scale1d")
73
}
74

75
#' @export
76
textplot_scale1d.default <-  function(x,
77
                                      margin = c("documents", "features"),
78
                                      doclabels = NULL,
79
                                      sort = TRUE, groups = NULL,
80
                                      highlighted = NULL, alpha = 0.7,
81
                                      highlighted_color = "black") {
82 1
    stop(friendly_class_undefined_message(class(x), "textplot_scale1d"))
83
}
84

85
#' @importFrom stats reorder aggregate
86
#' @importFrom ggplot2 ggplot aes geom_point element_blank geom_pointrange
87
#' @importFrom ggplot2 coord_flip xlab ylab theme_bw geom_text theme geom_point
88
#' @importFrom ggplot2 facet_grid element_line
89
#' @export
90
textplot_scale1d.textmodel_wordfish <-  function(x,
91
                                                 margin = c("documents", "features"),
92
                                                 doclabels = NULL,
93
                                                 sort = TRUE,
94
                                                 groups = NULL,
95
                                                 highlighted = NULL,
96
                                                 alpha = 0.7,
97
                                                 highlighted_color = "black") {
98 1
    margin <- match.arg(margin)
99 1
    if (is.null(doclabels)) doclabels <- x$docs
100

101 1
    if (margin == "documents") {
102 1
        p <- textplot_scale1d_documents(x$theta,
103 1
                                        x$se.theta,
104 1
                                        doclabels = doclabels,
105 1
                                        sort = sort,
106 1
                                        groups = groups) +
107 1
            ylab("Estimated theta")
108 1
    } else if (margin == "features") {
109 1
        p <- textplot_scale1d_features(x$beta,
110 1
                                       weight = x$psi,
111 1
                                       featlabels = x$features,
112 1
                                       highlighted = highlighted, alpha = alpha,
113 1
                                       highlighted_color = highlighted_color) +
114 1
            xlab("Estimated beta") +
115 1
            ylab("Estimated psi")
116
    }
117 1
    apply_theme(p)
118
}
119

120
#' @importFrom stats reorder aggregate
121
#' @importFrom ggplot2 ggplot aes geom_point element_blank geom_pointrange
122
#' @importFrom ggplot2 coord_flip xlab ylab theme_bw geom_text theme geom_point
123
#' @importFrom ggplot2 facet_grid element_line
124
#' @method textplot_scale1d predict.textmodel_wordscores
125
#' @export
126
textplot_scale1d.predict.textmodel_wordscores <- function(x,
127
                                                          margin = c("documents", "features"),
128
                                                          doclabels = NULL,
129
                                                          sort = TRUE,
130
                                                          groups = NULL,
131
                                                          highlighted = NULL,
132
                                                          alpha = 0.7,
133
                                                          highlighted_color = "black") {
134 1
    margin <- match.arg(margin)
135 1
    if (is.null(doclabels)) doclabels <- get_docname(x)
136

137

138 1
    if (margin == "documents") {
139 1
        p <- textplot_scale1d_documents(get_fitted(x),
140 1
                                        get_sefit(x),
141 1
                                        doclabels = doclabels,
142 1
                                        sort = sort,
143 1
                                        groups = groups) +
144 1
              ylab("Document position")
145

146 1
    } else if (margin == "features") {
147 1
        stop("This margin can only be run on a fitted wordscores object.")
148
    }
149 1
    apply_theme(p)
150
}
151

152

153
#' @export
154
textplot_scale1d.textmodel_wordscores <- function(x,
155
                                                  margin = c("features", "documents"),
156
                                                  doclabels = NULL,
157
                                                  sort = TRUE,
158
                                                  groups = NULL,
159
                                                  highlighted = NULL,
160
                                                  alpha = 0.7,
161
                                                  highlighted_color = "black") {
162 1
    margin <- match.arg(margin)
163 1
    if (margin == "documents") {
164 1
        stop("This margin can only be run on a predicted wordscores object.")
165 1
    } else if (margin == "features") {
166 1
        p <- textplot_scale1d_features(x$wordscores,
167 1
                                       weight = log(colSums(x$x[, names(x$wordscores)])),
168 1
                                       featlabels = names(x$wordscores),
169 1
                                       highlighted = highlighted, alpha = alpha,
170 1
                                       highlighted_color = highlighted_color) +
171 1
            xlab("Word score") +
172 1
            ylab("log(term frequency)")
173 1
        apply_theme(p)
174
    }
175
}
176

177
#' @importFrom stats reorder aggregate
178
#' @importFrom ggplot2 ggplot aes geom_point element_blank geom_pointrange
179
#' @importFrom ggplot2 coord_flip xlab ylab theme_bw geom_text theme geom_point
180
#' @importFrom ggplot2 facet_grid element_line
181
#' @export
182
textplot_scale1d.textmodel_ca <- function(x,
183
                                          margin = c("documents", "features"),
184
                                          doclabels = NULL,
185
                                          sort = TRUE,
186
                                          groups = NULL,
187
                                          highlighted = NULL,
188
                                          alpha = 0.7,
189
                                          highlighted_color = "black") {
190 1
    margin <- match.arg(margin)
191 1
    if (is.null(doclabels)) doclabels <- x$rownames
192

193 1
    if (margin == "documents") {
194 1
        p <- textplot_scale1d_documents(coef(x)$coef_document,
195 1
                                        coef(x)$coef_document_se,
196 1
                                        doclabels = doclabels,
197 1
                                        sort = sort,
198 1
                                        groups = groups) +
199 1
            ylab("Document position")
200

201
    } else {
202 1
        stop("textplot_scale1d for features not implemented for CA models")
203
    }
204 1
    apply_theme(p)
205
}
206

207

208
# internal functions ------------------------
209

210
textplot_scale1d_documents <- function(x, se, doclabels, sort = TRUE,
211
                                       groups = NULL) {
212

213 1
    if (!is.null(doclabels))
214 1
        stopifnot(length(doclabels) == length(x))
215

216 1
    if (all(is.na(se))) se <- 0
217

218 1
    if (sort & !is.null(groups)) {
219 1
        temp_medians <- aggregate(x, list(groups), median, na.rm = TRUE)
220 1
        groups <- factor(groups,
221 1
                         levels = temp_medians[order(temp_medians$x, decreasing = TRUE), 1])
222
    }
223

224 1
    theta <- lower <- upper <- NULL
225 1
    results <- data.frame(doclabels = doclabels,
226 1
                          theta = x,
227 1
                          lower = x - 1.96 * se,
228 1
                          upper = x + 1.96 * se)
229 1
    if (!is.null(groups))
230 1
        results$groups <- groups
231

232 1
    p <- if (sort) {
233 1
        ggplot(data = results, aes(x = reorder(doclabels, theta), y = theta))
234
    } else {
235 1
        ggplot(data = results, aes(x = doclabels, y = theta))
236
    }
237

238 1
    p <- p +
239 1
        coord_flip() +
240 1
        geom_point(size = 1) +
241 1
        geom_pointrange(aes(ymin = lower, ymax = upper),
242 1
                        lwd = .25, fatten = .4) +
243 1
        xlab(NULL)
244 1
    if (!is.null(groups)) {
245 1
        p <- p + facet_grid(as.factor(groups) ~ ., scales = "free_y", space = "free")
246
    }
247 1
    p
248
}
249

250
##
251
## internal function to plot document scaling
252
##
253
textplot_scale1d_features <- function(x, weight, featlabels,
254
                                      highlighted = NULL, alpha = 0.7,
255
                                      highlighted_color = "black") {
256

257 1
    beta <- psi <- feature <- NULL
258 1
    results <- data.frame(feature = featlabels,
259 1
                          psi = weight,
260 1
                          beta = x)
261 1
    p <- ggplot(data = results, aes(x = beta, y = psi, label = feature)) +
262 1
        geom_text(colour = "grey70", alpha = alpha) +
263 1
        geom_text(aes(beta, psi, label = feature),
264 1
                  data = results[results$feature %in% highlighted,],
265 1
                  color = highlighted_color) +
266 1
        xlab("Beta") +
267 1
        ylab("Psi") +
268 1
        theme(panel.grid.major = element_blank(),
269 1
              panel.grid.minor = element_blank())
270 1
    p
271
}
272

273
##
274
## common minimal B&W theme
275
##
276
apply_theme <- function(p) {
277 1
    p + theme_bw() +
278 1
        theme(panel.background = ggplot2::element_blank(),
279 1
              panel.grid.major.x = element_blank(),
280 1
              panel.grid.minor.x = element_blank(),
281
              # panel.grid.major.y = element_blank(),
282 1
              panel.grid.minor.y = element_blank(),
283 1
              plot.background = element_blank(),
284 1
              axis.ticks.y = element_blank(),
285
              # panel.spacing = grid::unit(0.1, "lines"),
286 1
              panel.grid.major.y = element_line(linetype = "dotted"))
287
}
288

289
get_docname <- function(x) {
290 1
    if (is.list(x)) {
291 1
        if (is.matrix(x$fit)) {
292 1
            return(rownames(x$fit))
293
        } else {
294 1
            return(names(x$fit))
295
        }
296
    } else {
297 1
        return(names(x))
298
    }
299
}
300

301
get_fitted <- function(x) {
302 1
    if (is.list(x)) {
303 1
        if (is.matrix(x$fit)) {
304 1
            return(x$fit[, "fit", drop = TRUE])
305
        } else {
306 1
            return(x$fit)
307
        }
308
    } else {
309 1
        return(x)
310
    }
311
}
312

313
get_sefit <- function(x) {
314 1
    if (is.list(x)) {
315 1
        if (is.matrix(x$fit)) {
316 1
            return((x$fit[, "fit", drop = TRUE] - x$fit[, "lwr", drop = TRUE]) / 1.96)
317
        } else {
318 1
            return(x$se.fit)
319
        }
320
    } else {
321 1
        return(rep(0, length(x)))
322
    }
323
}

Read our documentation on viewing source code .

Loading