R/timeSeries.R

In sentopics: Tools for Joint Sentiment and Topic Analysis of Textual Data

#' Internal sentiment
#'
#' @family sentopics helpers
#'
#' @author Olivier Delmarcelle
#'
#' @description Compute, extract or replace the internal sentiment of a
#'   `sentopicsmodel`. The internal sentiment is used to create time series using
#'   the functions [sentiment_series()] or [sentiment_topics()]. If the input
#'   model contains a sentiment layer, sentiment can be computed directly from
#'   the output of the model. Otherwise, sentiment obtained externally should be
#'   added for each document.
#'
#' @param x a `sentopicsmodel` created from the [LDA()], [JST()], [rJST()] or
#'   [sentopicsmodel()] function
#' @param method the method used to compute sentiment, see "Methods" below.
#'   Ignored if an internal sentiment is already stored, unless `override` is
#'   `TRUE`.
#' @param override by default, the function computes sentiment only if no
#'   internal sentiment is already stored within the `sentopicsmodel` object.
#'   This avoid, for example, erasing externally provided sentiment. Set to
#'   `TRUE` to force computation of new sentiment values. Only useful for models
#'   with a sentiment layer.
#' @param quiet if `FALSE`, print a message when internal sentiment is found.
#' @param include_docvars if `TRUE` the function will return all docvars stored
#'   in the internal `tokens` object of the model
#'
#' @return A data.frame with the stored sentiment per document.
#'
#' @details The computed sentiment varies depending on the model. For [LDA],
#'   sentiment computation is not possible.
#'
#'   For [JST], the sentiment is computed on a per-document basis according to
#'   the document-level sentiment mixtures.
#'
#'   For a [rJST] model, sentiment is computed from the sentiment probabilities
#'   conditional on each topic, resulting in `K` sentiment values per document
#'   in the `.s_` columns. The `.sentiment` column is an average of these values,
#'   weighted once by their respective topic proportions.
#'
#' @section Methods:
#'
#'   The function accepts two methods of computing sentiment:
#'
#'   - **proportional** computes the difference between the estimated positive
#'   and negative proportions for each document (and possibly each topic).
#'   \deqn{positive - negative}
#'
#'   - **proportionalPol** computes the difference between positive and negative
#'   proportions, divided by the sum of positive and negative proportions. As a
#'   result, the computed sentiment lies within the (-1;1) interval.
#'   \deqn{\frac{positive - negative}{positive + negative}}{(positive -
#'   negative) / (positive + negative)}
#'
#'   Both methods will lead to the same result for a JST model containing only
#'   negative and positive sentiments.
#'
#' @note The internal sentiment is stored internally in the *docvars* of the
#'   topic model. This means that sentiment may also be accessed through the
#'   [docvars()] function, although this is discouraged.
#'
#'   When sentiment is computed, the result is cached by modifying the model's
#'   `tokens` docvars. If a `.sentiment` docvar already exists and
#'   `override = FALSE`, the value is returned without recomputing or modifying
#'   the model.
#'
#' @export
#' @examples
#' \donttest{# sentiment from an external source can be added to the model
#' lda <- LDA(ECB_press_conferences_tokens)
#' scores <- compute_PicaultRenault_scores(ECB_press_conferences)
#' sentopics_sentiment(lda) <- scores[names(lda$tokens), "EC"]
#'
#' # using the helper function extracts the stored sentiment
#' sentopics_sentiment(lda)
#'
#' # internally, the sentiment is stored in the docvars of the tokens
#' docvars(lda$tokens, ".sentiment")
#'
#' # sentiment can be removed or modified by the assignment operator
#' sentopics_sentiment(lda) <- NULL
#' sentopics_sentiment(lda) <- scores[names(lda$tokens), "EC"]
#'
#' # for JST models, sentiment can be computed from the output of the model
#' jst <- JST(ECB_press_conferences_tokens, lexicon = LoughranMcDonald)
#' jst <- fit(jst, 100)
#' sentopics_sentiment(jst) # compute sentiment
#'
#' ## for rJST models one sentiment value is computed by topic
#' rjst <- rJST(ECB_press_conferences_tokens, lexicon = LoughranMcDonald)
#' rjst <- fit(rjst, 100)
#' sentopics_sentiment(rjst)}
sentopics_sentiment <- function(
  x,
  method = c("proportional", "proportionalPol"),
  override = FALSE,
  quiet = FALSE,
  include_docvars = FALSE
) {
  ## CMD check
  .id <- positive <- negative <- topic <- L1_prob <- NULL

  docvars <- attr(x$tokens, "docvars")

  if (!override & ".sentiment" %in% names(docvars)) {
    if (!quiet & !inherits(x, "LDA")) {
      message(
        "'.sentiment' docvars found. Returning these values. To re-compute sentiment, please set `override = TRUE`."
      )
    }
    if (include_docvars) {
      res <- data.table(.id = names(x$tokens), docvars(x$tokens))
      if (".sentiment_scaled" %in% names(docvars)) {
        data.table::setcolorder(
          res,
          c(".id", ".sentiment", ".sentiment_scaled")
        )
      } else {
        data.table::setcolorder(res, c(".id", ".sentiment"))
      }
    } else {
      if (".sentiment_scaled" %in% names(docvars)) {
        res <-
          data.table(
            .id = names(x$tokens),
            .sentiment = docvars$`.sentiment`,
            .sentiment_scaled = docvars$`.sentiment_scaled`
          )
      } else {
        res <- data.table(
          .id = names(x$tokens),
          .sentiment = docvars$`.sentiment`
        )
      }
      if (attr(x, "Sdim") == "L2") {
        idx <- grepl("^\\.s_", names(docvars))
        res <- cbind(res, docvars[, idx])
      }
    }
    return(res[])
  }

  if (inherits(x, "LDA")) {
    stop(
      "Impossible to compute sentiment for an LDA model. Please input first a '.sentiment' docvars by either\n\t1: ensuring the presence of a '.sentiment' docvars in the dfm or tokens object used to create the model.\n\t2: using `sentopics_sentiment(x) <- value` to register a vector of sentiment values in the topic model object."
    )
  }
  if (any(!c("positive", "negative") %in% levels(x$vocabulary$lexicon))) {
    stop(
      "Sentiment computation requires defined positive and negative sentiment. Ensure that a lexicon containing negative and positive categories was provided when creating the model or input a '.sentiment' docvars by either\n\t1: ensuring the presence of a '.sentiment' docvars in the dfm or tokens object used to create the model.\n\t2: using `sentopics_sentiment(x) <- value` to register a vector of sentiment values in the topic model object."
    )
  }

  method <- match.arg(method)
  melted <- melt(x, include_docvars = FALSE)
  ## store order to reverse dcast ordering
  # ord <- order(unique(melted$.id))

  switch(
    method,
    proportionalPol = {
      fn <- function(dt) {
        dt[, list(
          .id,
          .sentiment = (positive - negative) / (positive + negative)
        )]
      }
    },
    proportional = {
      fn <- function(dt) {
        dt[, list(.id, .sentiment = (positive - negative))]
      }
    }
  )

  # Remove topic-specific sentiment and scaled values if any
  if (".sentiment_scaled" %in% names(docvars)) {
    docvars$`.sentiment_scaled` <- NULL
  }
  cols <- grep("^\\.s_", names(docvars), value = TRUE)
  for (c in cols) {
    docvars[[c]] <- NULL
  }

  if (attr(x, "Sdim") == "L1") {
    ## then it is JST

    ## discard topics, only need L1_prob
    # res <- dcast(melted, .id ~ sent, value.var = "L1_prob", fun.aggregate = mean)
    res <- dcast(
      melted[, list("L1_prob" = mean(L1_prob)), by = c("sent", ".id")],
      .id ~ sent,
      value.var = "L1_prob"
    )
    res <- fn(res)

    ## recover initial ordering
    setkey(res, NULL)
    # res <- res[order(ord)]
    res <- res[match(unique(melted$.id), .id)]
    stopifnot(identical(res$.id, names(x$tokens)))

    docvars$`.sentiment` <- res$`.sentiment`
    data.table::setattr(x$tokens, "docvars", docvars)
    message("Sentiment computed and assigned internally")
  } else {
    LIST <- lapply(
      stats::setNames(
        levels(melted$topic),
        nm = paste0(".s_", levels(melted$topic))
      ),
      function(t) {
        # L2_prob is conditional on topic; prob already includes its weight.
        fn(dcast(melted[topic == t], .id ~ sent, value.var = "L2_prob"))
      }
    )
    res <- data.table::rbindlist(LIST, idcol = "topic")
    res <- dcast(res, .id ~ topic, value.var = ".sentiment")

    ## dcast sorts the character topic labels, but theta is ordered by topic
    ## index. Restore the model's topic order before multiplying positionally.
    topic_cols <- paste0(".s_", colnames(x$theta))
    data.table::setcolorder(res, c(".id", topic_cols))

    ## recover initial ordering
    setkey(res, NULL)
    # res <- res[order(ord)]
    res <- res[match(unique(melted$.id), .id)]
    stopifnot(identical(res$.id, names(x$tokens)))

    res$.sentiment <- rowSums(as.matrix(res, rownames = ".id") * x$theta)
    data.table::setcolorder(res, c(".id", ".sentiment"))

    docvars <- utils::modifyList(docvars, res[, -".id"])
    data.table::setattr(x$tokens, "docvars", docvars)
    message("Sentiment computed and assigned internally")
  }
  ## to recompute at the end of merge_topics, need this attribute
  data.table::setattr(x, "sentiment_not_external", TRUE)

  if (include_docvars) {
    res <- cbind(res, docvars(x$tokens))
  }

  res[]
}


#' @rdname sentopics_sentiment
#' @param value a numeric vector of sentiment to input into the model.
#' @export
`sentopics_sentiment<-` <- function(x, value) {
  if (!inherits(x, "sentopicsmodel")) {
    stop(
      "Replacement of internal sentiment is only possible for topic models of package `sentopics`"
    )
  }
  if (anyNA(value)) {
    stop("NA sentiment not allowed.")
  }

  docvars <- attr(x$tokens, "docvars")
  if (".sentiment" %in% names(docvars) && !is.null(value)) {
    message("Replacing existing '.sentiment' docvars")
  }

  # Sentiment values and their scaled counterparts are always replaced
  # together, regardless of whether a new sentiment value is provided.
  cleanup_cols <- c(
    ".sentiment_scaled",
    grep("^\\.s_", names(docvars), value = TRUE)
  )
  cleanup_cols <- cleanup_cols[cleanup_cols %in% names(docvars)]
  for (c in cleanup_cols) {
    quanteda::docvars(x$tokens, c) <- NULL
  }

  if (is.null(value)) {
    x$tokens$`.sentiment` <- NULL
  } else {
    x$tokens$`.sentiment` <- value
  }
  attr(x, "sentiment_not_external") <- NULL

  x
}

#' Internal date
#' @author Olivier Delmarcelle
#' @family sentopics helpers
#' @inheritParams sentopics_sentiment
#' @description Extract or replace the internal dates of a `sentopicsmodel`. The
#'   internal dates are used to create time series using the functions
#'   [sentiment_series()] or [sentiment_topics()]. Dates should be provided by
#'   using `sentopics_date(x) <- value` or by storing a '.date' docvars in
#'   the [tokens] object used to create the model.
#' @export
#'
#' @note The internal date is stored internally in the *docvars* of the topic
#'   model. This means that dates may also be accessed through the [docvars()]
#'   function, although this is discouraged.
#'
#' @return a data.frame with the stored date per document.
#' @examples
#' # example dataset already contains ".date" docvar
#' docvars(ECB_press_conferences_tokens)
#' # dates are automatically stored in the sentopicsmodel object
#' lda <- LDA(ECB_press_conferences_tokens)
#' sentopics_date(lda)
#'
#' # dates can be removed or modified by the assignment operator
#' sentopics_date(lda) <- NULL
#' sentopics_date(lda) <- docvars(ECB_press_conferences_tokens, ".date")
sentopics_date <- function(x, include_docvars = FALSE) {
  docvars <- quanteda::docvars(x$tokens)
  if (!".date" %in% names(docvars)) {
    stop(
      "No dates stored internally. Please add dates to the documents by either\n\t1: ensuring the presence of a '.date' docvars in the dfm or tokens object used to create the model.\n\t2: using `sentopics_date(x) <- value` to register a vector of Dates in the topic model object."
    )
  }
  if (include_docvars) {
    res <- data.table(.id = names(x$tokens), docvars(x$tokens))
    data.table::setcolorder(res, c(".id", ".date"))
  } else {
    res <- data.table(.id = names(x$tokens), .date = as.Date(docvars$`.date`))
  }
  res[]
}
#' @rdname sentopics_date
#' @param value a `Date`-coercible vector of dates to input into the model.
#' @export
`sentopics_date<-` <- function(x, value) {
  if (!inherits(x, "sentopicsmodel")) {
    stop(
      "Replacement of internal date is only possible for topic models of package `sentopics`"
    )
  }
  if (anyNA(value)) {
    stop("NA date not allowed.")
  }

  docvars <- attr(x$tokens, "docvars")
  if (".date" %in% names(docvars) & !is.null(value)) {
    message("Replacing existing '.date' docvars")
  }

  if (!is.null(value)) {
    x$tokens$`.date` <- as.Date(value)
  }
  if (is.null(value)) {
    x$tokens$`.date` <- NULL
  }

  x
}


#' Setting topic or sentiment labels
#'
#' @author Olivier Delmarcelle
#' @family sentopics helpers
#' @inheritParams sentopics_sentiment
#' @description Extract or replace the labels of a `sentopicsmodel`. The replaced
#'   labels will appear in most functions dealing with the output of the
#'   `sentomicmodel`.
#' @param flat if FALSE, return a list of dimension labels instead of a
#'   character vector.
#' @export
#' @seealso merge_topics
#' @return a character vector of topic/sentiment labels.
#' @examples
#' # by default, sentopics_labels() generate standard topic names
#' lda <- LDA(ECB_press_conferences_tokens)
#' sentopics_labels(lda)
#'
#' # to change labels, a named list must be provided
#' sentopics_labels(lda) <- list(
#'  topic = paste0("superTopic", 1:lda$K)
#' )
#' sentopics_labels(lda)
#'
#' # using NULL remove labels
#' sentopics_labels(lda) <- NULL
#' sentopics_labels(lda)
#'
#' # also works for JST/rJST models
#' jst <- JST(ECB_press_conferences_tokens)
#' sentopics_labels(jst) <- list(
#'   topic = paste0("superTopic", 1:jst$K),
#'   sentiment = c("negative", "neutral", "positive")
#' )
#' sentopics_labels(jst)
#'
#' # setting flat = FALSE return a list or labels for each dimension
#' sentopics_labels(jst, flat = FALSE)
sentopics_labels <- function(x, flat = TRUE) {
  res <- create_labels(x, flat = flat)
  if (!flat) {
    params <- sentopicsmodel_params(x)
    dimension_names <- c(L1 = params$L1_name, L2 = params$L2_name)
    names(res) <- unname(dimension_names[names(res)])
  }
  res
}
#' @rdname sentopics_labels
#' @param value a list of future labels for the topic model. The list should be
#'   named and contain a character vector for each dimension to label. See the
#'   examples for a correct usage.
#' @export
`sentopics_labels<-` <- function(x, value) {
  if (is.null(value)) {
    attr(x, "labels") <- NULL
    x <- fit(x, 0, displayProgress = FALSE)
    return(x)
  }

  if (!is.list(x)) {
    stop("Only accepts list as input")
  }
  if (length(setdiff(names(value), c("topic", "sentiment"))) > 0) {
    stop("List should only contain named components 'topic' or 'sentiment'.")
  }
  if (length(value) < 1) {
    warning("Empty input, nothing is replaced.")
  }
  if (length(names(value)) < 1) {
    warning("Input list should be named.")
  }

  params <- sentopicsmodel_params(x)
  old_topic_labels <- if (!is.null(value$topic)) {
    sentopics_labels(x, flat = FALSE)$topic
  }
  if (is.null(attr(x, "labels"))) {
    attr(x, "labels") <- list()
  }
  if (params$L1_name %in% names(value)) {
    if (length(value[[params$L1_name]]) != params$L1) {
      stop(
        "The number of ",
        params$L1_name,
        " labels should match the number of topics."
      )
    }
    attr(x, "labels")[["L1"]] <- value[[params$L1_name]]
    if (params$Sdim == "L1") {
      levels(x$vocabulary$lexicon) <- value[[params$L1_name]]
    }
  }
  if (params$L2_name %in% names(value)) {
    if (length(value[[params$L2_name]]) != params$L2) {
      stop(
        "The number of ",
        params$L2_name,
        " labels should match the number of topics."
      )
    }
    attr(x, "labels")[["L2"]] <- value[[params$L2_name]]
    if (params$Sdim == "L2") {
      levels(x$vocabulary$lexicon) <- value[[params$L2_name]]
    }
  }

  ## force update of labels on theta phi ect..
  x <- fit(x, 0, displayProgress = FALSE)

  ## manually adjust stored sentiment in docvars (if any)
  docvars <- attr(x$tokens, "docvars")
  if (!is.null(docvars) && !is.null(value$topic)) {
    old_columns <- paste0(".s_", old_topic_labels)
    new_columns <- paste0(".s_", value$topic)
    docvar_names <- names(docvars)

    for (suffix in c("", "_scaled")) {
      idx <- match(paste0(old_columns, suffix), docvar_names)
      matched <- !is.na(idx)
      docvar_names[idx[matched]] <- paste0(new_columns[matched], suffix)
    }

    names(docvars) <- docvar_names
    attr(x$tokens, "docvars") <- docvars
  }

  x
}


#' Compute a sentiment time series
#'
#' @family series functions
#' @inheritParams sentiment_topics
#'
#' @param x a [LDA()], [JST()] or [rJST()] model populated with internal dates
#'   and/or internal sentiment.
#'
#' @description Compute a sentiment time series based on the internal sentiment
#'   and dates of a `sentopicsmodel`. The time series computation supports
#'   multiple sampling period and optionally allow computing a moving average.
#'
#' @return A time series of sentiment, stored as an [xts::xts] or
#'   data.frame.
#' @export
#' @seealso sentopics_sentiment sentopics_date
#' @examples
#' \donttest{
#' lda <- LDA(ECB_press_conferences_tokens)
#' scores <- compute_PicaultRenault_scores(ECB_press_conferences)
#' sentopics_sentiment(lda) <- scores[names(lda$tokens), "EC"]
#' series <- sentiment_series(lda, period = "month")
#'
#' # JST and rJST models can use computed sentiment from the sentiment layer,
#' # but the model must be estimated first.
#' rjst <- rJST(ECB_press_conferences_tokens, lexicon = LoughranMcDonald)
#' rjst <- fit(rjst, 10)
#' sentiment_series(rjst)
#'
#' # note the presence of both raw and scaled sentiment values
#' # in the initial object
#' sentopics_sentiment(lda)
#' sentopics_sentiment(rjst)
#' }
sentiment_series <- function(
  x,
  period = c("year", "quarter", "month", "day"),
  rolling_window = 1,
  scale = TRUE,
  scaling_period = c("1900-01-01", "2099-12-31"),
  as.xts = TRUE,
  ...
) {
  ## CMD check
  .date <- .sentiment <- sentiment <- NULL

  period <- match.arg(period)

  mis <- c()
  if (rolling_window > 1) {
    mis <- c("zoo")
  }
  if (as.xts) {
    mis <- c(mis, "xts")
  }
  mis <- missingSuggets(mis)
  if (length(mis) > 0) {
    stop(
      "Suggested packages are missing for the sentiment_series function.\n",
      "Please install first the following packages: ",
      paste0(mis, collapse = ", "),
      ".\n",
      "Install command: install.packages(",
      paste0("'", mis, "'", collapse = ", "),
      ")"
    )
  }

  res <- cbind(
    sentopics_sentiment(x, quiet = TRUE),
    sentopics_date(x)
  )
  ## TODO: maybe expand to multiple columns?
  # res <- res[, lapply(.SD, mean),
  #            keyby = list(date = floor_date(.date, period)),
  #            .SDcols = ".sentiment"]
  res <- res[,
    list(sentiment = mean(.sentiment)),
    keyby = list(date = floor_date(.date, period))
  ]

  if (rolling_window > 1) {
    ## Store existing dates
    idx <- res$date
    ## Fill empty periods
    res <- merge(
      data.table(date = seq(min(res$date), max(res$date), by = period)),
      res,
      by = "date",
      all.x = TRUE
    )

    ## Set default parameter for rolling
    dots <- list(...)
    if (is.null(dots$FUN)) {
      dots$FUN <- mean
    }
    if (is.null(dots$na.rm)) {
      dots$na.rm <- TRUE
    }
    if (is.null(dots$fill)) {
      dots$fill <- NA
    }
    if (is.null(dots$align)) {
      dots$align <- "right"
    }

    # res <- res[, list(date, sentiment = zoo::rollapply(sentiment, rolling_window, FUN = FUN, na.rm = na.rm, fill = fill, align = align, ...))]
    res <- res[, list(
      date,
      sentiment = do.call(
        zoo::rollapply,
        c(
          list(data = sentiment, width = rolling_window),
          dots
        )
      )
    )]

    res <- res[date %in% idx]
  }

  if (scale) {
    if (nrow(res) < 2) {
      stop(
        "At least two periods are required to scale de series. Please the date range of documents or use a shorter period."
      )
    }
    ## Set default parameter for scaling
    dots <- list(...)
    na.rm <- if (is.null(dots$na.rm)) TRUE else dots$na.rm
    trim <- if (is.null(dots$trim)) 0 else dots$trim
    params <- res[
      date >= scaling_period[1] & date <= scaling_period[2],
      c(
        sigma = stats::sd(sentiment, na.rm = na.rm),
        mu = mean(sentiment, na.rm = na.rm, trim = trim)
      )
    ]

    res[, sentiment := (sentiment - params["mu"]) / params["sigma"]]
    ## Add scaled sentiment at the document level by reference
    {
      docvars <- attr(x$tokens, "docvars")
      docvars$`.sentiment_scaled` <- (docvars$`.sentiment` - params["mu"]) /
        params["sigma"]

      ## dealing with multiple values for rJST
      idx <- grepl("^\\.s_", names(docvars), perl = TRUE) &
        !grepl("_scaled$", names(docvars), perl = TRUE)
      if (any(idx)) {
        idx <- names(docvars)[idx]
        for (s in idx) {
          docvars[[paste0(s, "_scaled")]] <- (docvars[[s]] - params["mu"]) /
            params["sigma"]
        }
      }

      ## putting back the results in docvars
      data.table::setattr(x$tokens, "docvars", docvars)
    }
  }

  # res <- res[, list(s = mean(s)), by = list(date = floor_date(res[[date_docvar]], period))]
  if (as.xts & length(missingSuggets("xts")) == 0) {
    res <- xts::as.xts(res, dateFormat = "Date")
  }

  if (scale) {
    data.table::setattr(res, "scaling_parameters", params)
  }
  res[]
}


#' Breakdown the sentiment into topical components
#'
#' @family series functions
#' @inheritParams sentiment_topics
#'
#' @description Break down the sentiment series obtained with
#'   [sentiment_series()] into topical components. Sentiment is broken down at
#'   the document level using estimated topic proportions, then processed to
#'   create a time series and its components.
#'
#' @return A time series of sentiment, stored as an [xts::xts] object or as a
#'   data.frame.
#' @export
#'
#' @details The sentiment is broken down at the sentiment level assuming the
#'   following composition: \deqn{s = \sum^K_{i=1} s_i \times \theta_i}, where
#'   \eqn{s_i} is the sentiment of topic i and \eqn{theta_i} the proportion of
#'   topic i in a given document. For an LDA model, the sentiment of each topic
#'   is considered equal to the document sentiment (i.e. \eqn{s_i = s \forall i
#'   \in K}). The topical sentiment attention, defined by \eqn{s*_i = s_i \times
#'   \theta_i} represent the effective sentiment conveyed by a topic in a
#'   document. The topical sentiment attention of all documents in a period are
#'   averaged to compute the breakdown of the sentiment time series.
#' @seealso sentopics_sentiment sentopics_date
#' @examples
#' \donttest{lda <- LDA(ECB_press_conferences_tokens)
#' lda <- fit(lda, 100)
#' scores <- compute_PicaultRenault_scores(ECB_press_conferences)
#' sentopics_sentiment(lda) <- scores[names(lda$tokens), "EC"]
#' sentiment_breakdown(lda)
#'
#' # plot shortcut
#' plot_sentiment_breakdown(lda)
#'
#' # also available for rJST models (with topic-level sentiment)
#' rjst <- rJST(ECB_press_conferences_tokens, lexicon = LoughranMcDonald)
#' rjst <- fit(rjst, 100)
#' sentopics_sentiment(rjst) # compute sentiment
#' plot_sentiment_breakdown(rjst)}
sentiment_breakdown <- function(
  x,
  period = c("year", "quarter", "month", "day", "identity"),
  rolling_window = 1,
  scale = TRUE,
  scaling_period = c("1900-01-01", "2099-12-31"),
  plot = c(FALSE, TRUE, "silent"),
  as.xts = TRUE,
  ...
) {
  ## CMD check
  .id <- .date <- .sentiment <- .sentiment_scaled <- sentiment <- value <-
    variable <- width <- Topic <- date_center <- theta <- s <- ..cols <-
      prob <- NULL

  if (!inherits(x, c("LDA", "rJST"))) {
    stop("`sentiment_breakdown` is only implemented for LDA and rJST models.")
  }

  period <- match.arg(period)
  plot <- as.character(plot)
  plot <- match.arg(plot)
  plot <- as.logical(plot)

  mis <- c()
  if (rolling_window > 1) {
    mis <- c("zoo")
  }
  if (as.xts) {
    mis <- c(mis, "xts")
  }
  if (!isFALSE(plot)) {
    mis <- c(mis, "ggplot2")
  }
  mis <- missingSuggets(mis)
  if (length(mis) > 0) {
    stop(
      "Suggested packages are missing for the sentiment_breakdown function.\n",
      "Please install first the following packages: ",
      paste0(mis, collapse = ", "),
      ".\n",
      "Install command: install.packages(",
      paste0("'", mis, "'", collapse = ", "),
      ")"
    )
  }

  # proportions <- dcast(melt(x), .id ~ topic, value.var = "prob", fun.aggregate = sum)
  proportions <- dcast(
    melt(x)[, list(prob = sum(prob)), by = c("topic", ".id")],
    .id ~ topic,
    value.var = "prob"
  )

  if (scale & period != "identity") {
    invisible(sentiment_series(
      x,
      period = period,
      rolling_window = rolling_window,
      scale = scale,
      scaling_period = scaling_period,
      ...
    ))
    tmp_sent <- sentopics_sentiment(x, quiet = TRUE)
    cols <- grepl("^\\.s", names(tmp_sent)) & grepl("_scaled$", names(tmp_sent))
    cols <- names(tmp_sent)[cols]
    tmp_sent <- eval(substitute(
      tmp_sent[, c(".id", ..cols)],
      list(..cols = cols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # tmp_sent <- tmp_sent[, c(".id", ..cols), env = I(list(..cols = cols))]
    names(tmp_sent) <- gsub(
      "(^\\.(?!id))|(_scaled$)",
      "",
      names(tmp_sent),
      perl = TRUE
    )
  } else {
    tmp_sent <- sentopics_sentiment(x, quiet = TRUE)
    cols <- grepl("^\\.s", names(tmp_sent)) &
      !grepl("_scaled$", names(tmp_sent))
    cols <- names(tmp_sent)[cols]
    tmp_sent <- eval(substitute(
      tmp_sent[, c(".id", ..cols)],
      list(..cols = cols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # tmp_sent <- tmp_sent[, c(".id", ..cols), env = I(list(..cols = cols))]
    names(tmp_sent) <- gsub(
      "(^\\.(?!id))|(_scaled$)",
      "",
      names(tmp_sent),
      perl = TRUE
    )
  }

  proportions <- merge(
    merge(
      sentopics_date(x),
      tmp_sent,
      by = ".id",
      sort = FALSE
    ),
    proportions,
    by = ".id",
    sort = FALSE
  )

  ## early return
  if (period == "identity") {
    sCols <- names(proportions)[grepl("^s_", names(proportions))]
    if (length(sCols) == 0) {
      sCols <- "sentiment"
    }
    thetaCols <- sentopics_labels(x, flat = FALSE)[["topic"]]
    breakdown <- eval(substitute(
      proportions[, c(
        list(.id = .id, date = .date, sentiment = sentiment),
        mapply(
          function(s_i, theta_i) s_i * theta_i,
          theta_i = .SD[, theta],
          s_i = .SD[, s],
          SIMPLIFY = FALSE
        )
      )],
      list(s = sCols, theta = thetaCols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # breakdown <- proportions[, c(
    #   list(.id = .id, date = .date, sentiment = sentiment),
    #   mapply(function(s_i, theta_i) s_i * theta_i,
    #          theta_i = .SD[, theta], s_i = .SD[, s],
    #          SIMPLIFY = FALSE)),
    #   env = I(list( s = sCols, theta = thetaCols))]
    return(breakdown)
  }

  if (length(tmp_sent) <= 2) {
    ## then there is only one sentiment column
    if (inherits(x, "rJST")) {
      warning(
        "Sentiment for the rJST model comes from an external source. This means that the sentiment layer of the model is ignored. Was it really your intent? Perhaps should you run `sentopics_sentiment(x, override = TRUE)` on the model before calling this function, or instead remove the sentiment layer by using an LDA model."
      )
    }
    breakdown <- proportions[,
      c(
        list(sentiment = mean(sentiment)),
        lapply(.SD, function(x) mean(x * sentiment))
      ),
      .SDcols = -c(".id", ".date", "sentiment"),
      by = list(date = floor_date(.date, period))
    ]
  } else {
    ## deal with topical sentiment values (rJST)
    sCols <- names(proportions)[grepl("^s_", names(proportions))]
    thetaCols <- sentopics_labels(x, flat = FALSE)[["topic"]]
    breakdown <- eval(substitute(
      proportions[,
        c(
          list(sentiment = mean(sentiment)),
          mapply(
            function(s_i, theta_i) mean(s_i * theta_i),
            theta_i = .SD[, theta],
            s_i = .SD[, s],
            SIMPLIFY = FALSE
          )
        ),
        by = list(date = floor_date(.date, period))
      ],
      list(s = sCols, theta = thetaCols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # breakdown <- proportions[, c(list(sentiment = mean(sentiment)),
    #                              mapply(function(s_i, theta_i) mean(s_i * theta_i),
    #                                     theta_i = .SD[, theta], s_i = .SD[, s],
    #                                     SIMPLIFY = FALSE)),
    #                          by = list(date = floor_date(.date, period)),
    #                          env = I(list( s = sCols, theta = thetaCols))]
  }

  breakdown <- breakdown[order(date)]

  ## quick check
  if (
    !isTRUE(all.equal(
      breakdown$sentiment - rowSums(breakdown[, -c("date", "sentiment")]),
      rep(0, nrow(breakdown))
    ))
  ) {
    stop(
      "Computation of breakdown failed. Please contact the author of the package to report the issue."
    )
  }

  if (rolling_window > 1) {
    ## Store existing dates
    idx <- breakdown$date
    ## Fill empty periods
    breakdown <- merge(
      data.table(
        date = seq(min(breakdown$date), max(breakdown$date), by = period)
      ),
      breakdown,
      by = "date",
      all.x = TRUE
    )

    ## Set default parameter for rolling
    dots <- list(...)
    if (is.null(dots$FUN)) {
      dots$FUN <- mean
    }
    if (is.null(dots$na.rm)) {
      dots$na.rm <- TRUE
    }
    if (is.null(dots$fill)) {
      dots$fill <- NA
    }
    if (is.null(dots$align)) {
      dots$align <- "right"
    }

    cols <- setdiff(names(breakdown), c("date"))
    breakdown[,
      (cols) := lapply(.SD, function(col) {
        do.call(
          zoo::rollapply,
          c(
            list(data = col, width = rolling_window),
            dots
          )
        )
      }),
      .SDcols = cols
    ]

    breakdown <- breakdown[date %in% idx]
  }

  ## Prepare plot
  if (!isFALSE(plot)) {
    ## Store existing dates
    idx <- breakdown$date
    ## Fill empty periods
    breakdown <- merge(
      data.table(
        date = seq(min(breakdown$date), max(breakdown$date), by = period)
      ),
      breakdown,
      by = "date",
      all.x = TRUE
    )

    plot_data <- breakdown[, lapply(.SD, nafill, type = "locf")]
    plot_data <- stats::na.omit(melt(
      plot_data,
      id.vars = "date",
      variable.name = "Topic"
    ))
    plot_data[, width := days_period(date, period)]
    plot_data[,
      date_center := as.POSIXct(date) + as.difftime(width / 2, units = "days")
    ]

    p_breakdown <- ggplot2::ggplot(
      plot_data[Topic != "sentiment"],
      ggplot2::aes(x = date_center, y = value, fill = Topic)
    ) +
      ggplot2::geom_col(
        alpha = .8,
        position = ggplot2::position_stack(reverse = TRUE),
        width = plot_data[Topic != "sentiment"]$width * 24 * 60 * 60
      ) +
      ggplot2::geom_line(
        data = plot_data[Topic == "sentiment"],
        ggplot2::aes(x = date_center, y = value, group = 1L),
        inherit.aes = FALSE,
        linewidth = .8
      ) +
      ggplot2::scale_fill_manual(values = make_colors(x, "L1")) +
      ggplot2::ylab("Sentiment") +
      ggplot2::xlab("Date") +
      ggplot2::guides(fill = ggplot2::guide_legend(reverse = TRUE)) +
      # scale_x_date(name = "Date", date_breaks = "1 month", date_labels = "%B") +
      # theme_classic(base_size = 12) +
      # theme(legend.position = "bottom") +
      ggplot2::ggtitle("Sentiment breakdown")
    if (isTRUE(plot)) {
      print(p_breakdown)
    }
    breakdown <- breakdown[date %in% idx]
  }

  if (as.xts & length(missingSuggets("xts")) == 0) {
    breakdown <- xts::as.xts(breakdown, dateFormat = "Date")
  }

  if (!isFALSE(plot)) {
    attr(breakdown, "plot") <- p_breakdown
  }

  breakdown
}
#' @rdname sentiment_breakdown
#' @export
plot_sentiment_breakdown <- function(
  x,
  period = c("year", "quarter", "month", "day"),
  rolling_window = 1,
  scale = TRUE,
  scaling_period = c("1900-01-01", "2099-12-31"),
  ...
) {
  period <- match.arg(period)
  res <- sentiment_breakdown(
    x,
    period,
    rolling_window,
    scale,
    scaling_period,
    plot = "silent",
    as.xts = FALSE,
    ...
  )
  attr(res, "plot")
}

#' Compute time series of topical sentiments
#'
#' @family series functions
#'
#' @description Derive topical time series of sentiment from a [LDA()] or
#'   [rJST()] model. The time series are created by leveraging on estimated
#'   topic proportions and internal sentiment (for `LDA` models) or topical
#'   sentiment (for `rJST` models).
#'
#' @param x a [LDA()] or [rJST()] model populated with internal dates and/or
#'   internal sentiment.
#' @param period the sampling period within which the sentiment of documents
#'   will be averaged. `period = "identity"` is a special case that will return
#'   document-level variables before the aggregation happens. Useful to rapidly
#'   compute topical sentiment at the document level.
#' @param rolling_window if greater than 1, determines the rolling window to
#'   compute a moving average of sentiment. The rolling window is based on the
#'   period unit and rely on actual dates (i.e, is not affected by unequally
#'   spaced data points).
#' @param scale if `TRUE`, the resulting time series will be scaled to a mean of
#'   zero and a standard deviation of 1. This argument also has the side effect
#'   of attaching scaled sentiment values as *docvars* to the input object with
#'   the `_scaled` suffix.
#' @param scaling_period the date range over which the scaling should be
#'   applied. Particularly useful to normalize only the beginning of the time
#'   series.
#' @param plot if `TRUE`, prints a plot of the time series and attaches it as an
#'   attribute to the returned object. If `'silent'`, do not print the plot but
#'   still attaches it as an attribute.
#' @param plot_ridgelines if `TRUE`, time series are plotted as ridgelines.
#'   Requires `ggridges` package installed. If `FALSE`, the plot will use only
#'   standards `ggplot2` functions. If the argument is missing and the package
#'   `ggridges` is not installed, this will quietly switch to a `ggplot2`
#'   output.
#' @param as.xts if `TRUE`, returns an [xts::xts] object. Otherwise, returns a
#'   data.frame.
#' @param ... other arguments passed on to [zoo::rollapply()] or [mean()] and
#'   [sd()].
#'
#' @details A topical sentiment is computed at the document level for each
#'   topic. For an LDA model, the sentiment of each topic is considered equal to
#'   the document sentiment (i.e. \eqn{s_i = s \forall i \in K}). For a rJST
#'   model, these result from the proportions in the sentiment layer under each
#'   topic. To compute the topical time series, the topical sentiment of all
#'   documents in a period are aggregated according to their respective topic
#'   proportion. For example, for a given topic, the topical sentiment in period
#'   \eqn{t} is computed using: \deqn{s_t = \frac{\sum_{d = 1}^D s_d \times
#'   \theta_d}{\sum_{d = 1}^D \theta_d}}, where \eqn{s_d} is the sentiment of
#'   the topic in document d and \eqn{theta_d} the topic proportion in a
#'   document d.
#' @seealso sentopics_sentiment sentopics_date
#' @return an [xts::xts] or data.frame containing the time series of topical
#'   sentiments.
#' @export
#' @examples
#' \donttest{lda <- LDA(ECB_press_conferences_tokens)
#' lda <- fit(lda, 100)
#' scores <- compute_PicaultRenault_scores(ECB_press_conferences)
#' sentopics_sentiment(lda) <- scores[names(lda$tokens), "EC"]
#' sentiment_topics(lda)
#'
#' # plot shortcut
#' plot_sentiment_topics(lda, period = "month", rolling_window = 3)
#' # with or without ridgelines
#' plot_sentiment_topics(lda, period = "month", plot_ridgelines = FALSE)
#'
#' # also available for rJST models with internal sentiment computation
#' rjst <- rJST(ECB_press_conferences_tokens, lexicon = LoughranMcDonald)
#' rjst <- fit(rjst, 100)
#' sentopics_sentiment(rjst)
#' sentiment_topics(rjst)}
sentiment_topics <- function(
  x,
  period = c("year", "quarter", "month", "day", "identity"),
  rolling_window = 1,
  scale = TRUE,
  scaling_period = c("1900-01-01", "2099-12-31"),
  plot = c(FALSE, TRUE, "silent"),
  plot_ridgelines = TRUE,
  as.xts = TRUE,
  ...
) {
  ## CMD check
  .id <- .date <- .sentiment <- .sentiment_scaled <- sentiment <- value <-
    variable <- theta <- s <- ..cols <- prob <- NULL

  if (!inherits(x, c("LDA", "rJST"))) {
    stop("`sentiment_topics` is only implemented for LDA and rJST models.")
  }

  period <- match.arg(period)
  plot <- as.character(plot)
  plot <- match.arg(plot)
  plot <- as.logical(plot)

  mis <- c()
  if (rolling_window > 1) {
    mis <- c("zoo")
  }
  if (as.xts) {
    mis <- c(mis, "xts")
  }
  if (!isFALSE(plot)) {
    mis <- c(mis, "ggplot2")
  }
  if (missing(plot_ridgelines) & length(missingSuggets("ggridges") > 0)) {
    plot_ridgelines <- FALSE
  }
  if (plot_ridgelines & !isFALSE(plot)) {
    mis <- c(mis, "ggridges")
  }
  mis <- missingSuggets(mis)
  if (length(mis) > 0) {
    stop(
      "Suggested packages are missing for the sentiment_topics function.\n",
      "Please install first the following packages: ",
      paste0(mis, collapse = ", "),
      ".\n",
      "Install command: install.packages(",
      paste0("'", mis, "'", collapse = ", "),
      ")"
    )
  }

  # proportions <- dcast(melt(x), .id ~ topic, value.var = "prob", fun.aggregate = sum)
  proportions <- dcast(
    melt(x)[, list(prob = sum(prob)), by = c("topic", ".id")],
    .id ~ topic,
    value.var = "prob"
  )

  if (scale & period != "identity") {
    invisible(sentiment_series(
      x,
      period = period,
      rolling_window = rolling_window,
      scale = scale,
      scaling_period = scaling_period,
      ...
    ))
    tmp_sent <- sentopics_sentiment(x, quiet = TRUE)
    cols <- grepl("^\\.s", names(tmp_sent)) & grepl("_scaled$", names(tmp_sent))
    cols <- names(tmp_sent)[cols]
    tmp_sent <- eval(substitute(
      tmp_sent[, c(".id", ..cols)],
      list(..cols = cols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # tmp_sent <- tmp_sent[, c(".id", ..cols), env = I(list(..cols = cols))]
    names(tmp_sent) <- gsub(
      "(^\\.(?!id))|(_scaled$)",
      "",
      names(tmp_sent),
      perl = TRUE
    )
  } else {
    tmp_sent <- sentopics_sentiment(x, quiet = TRUE)
    cols <- grepl("^\\.s", names(tmp_sent)) &
      !grepl("_scaled$", names(tmp_sent))
    cols <- names(tmp_sent)[cols]
    tmp_sent <- eval(substitute(
      tmp_sent[, c(".id", ..cols)],
      list(..cols = cols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # tmp_sent <- tmp_sent[, c(".id", ..cols), env = I(list(..cols = cols))]
    names(tmp_sent) <- gsub(
      "(^\\.(?!id))|(_scaled$)",
      "",
      names(tmp_sent),
      perl = TRUE
    )
  }

  proportions <- merge(
    merge(
      sentopics_date(x),
      tmp_sent,
      by = ".id",
      sort = FALSE
    ),
    proportions,
    by = ".id",
    sort = FALSE
  )

  ## early return
  if (period == "identity") {
    sCols <- names(proportions)[grepl("^s_", names(proportions))]
    if (length(sCols) == 0) {
      sCols <- "sentiment"
    }
    thetaCols <- sentopics_labels(x, flat = FALSE)[["topic"]]
    topical_sent <- eval(substitute(
      proportions[, c(
        list(.id = .id, date = .date),
        mapply(
          function(s_i, theta_i) s_i * theta_i,
          theta_i = .SD[, theta],
          s_i = .SD[, s],
          SIMPLIFY = FALSE
        )
      )],
      list(s = sCols, theta = thetaCols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # topical_sent <- proportions[, c(
    #   list(.id = .id, date = .date),
    #   mapply(function(s_i, theta_i) s_i * theta_i,
    #          theta_i = .SD[, theta], s_i = .SD[, s],
    #          SIMPLIFY = FALSE)),
    #   env = I(list( s = sCols, theta = thetaCols))]
    return(topical_sent)
  }

  if (length(tmp_sent) <= 2) {
    ## then there is only one sentiment column
    if (inherits(x, "rJST")) {
      warning(
        "Sentiment for the rJST model comes from an external source. This means that the sentiment layer of the model is ignored. Was it really your intent? Perhaps should you run `sentopics_sentiment(x, override = TRUE)` on the model before calling this function, or instead remove the sentiment layer by using an LDA."
      )
    }
    topical_sent <- proportions[,
      c(lapply(.SD, function(w) sum(w * sentiment) / sum(w))),
      .SDcols = -c(".id", ".date", "sentiment"),
      by = list(date = floor_date(.date, period))
    ]
  } else {
    ## deal with topical sentiment values (rJST)
    sCols <- names(proportions)[grepl("^s_", names(proportions))]
    thetaCols <- sentopics_labels(x, flat = FALSE)[["topic"]]
    topical_sent <- eval(substitute(
      proportions[,
        mapply(
          function(s_i, theta_i) sum(s_i * theta_i) / sum(theta_i),
          theta_i = .SD[, theta],
          s_i = .SD[, s],
          SIMPLIFY = FALSE
        ),
        by = list(date = floor_date(.date, period))
      ],
      list(s = sCols, theta = thetaCols)
    ))
    # TODO: re-activate once data.table 1.14.3 is released.
    # topical_sent <- proportions[, mapply(function(s_i, theta_i) sum(s_i * theta_i) / sum(theta_i),
    #                                      theta_i = .SD[, theta], s_i = .SD[, s],
    #                                      SIMPLIFY = FALSE),
    #                             by = list(date = floor_date(.date, period)),
    #                             env = I(list( s = sCols, theta = thetaCols))]
  }

  topical_sent <- topical_sent[order(date)]

  if (rolling_window > 1) {
    ## Store existing dates
    idx <- topical_sent$date
    ## Fill empty periods
    topical_sent <- merge(
      data.table(
        date = seq(min(topical_sent$date), max(topical_sent$date), by = period)
      ),
      topical_sent,
      by = "date",
      all.x = TRUE
    )

    ## Set default parameter for rolling
    dots <- list(...)
    if (is.null(dots$FUN)) {
      dots$FUN <- mean
    }
    if (is.null(dots$na.rm)) {
      dots$na.rm <- TRUE
    }
    if (is.null(dots$fill)) {
      dots$fill <- NA
    }
    if (is.null(dots$align)) {
      dots$align <- "right"
    }

    cols <- setdiff(names(topical_sent), c("date"))
    topical_sent[,
      (cols) := lapply(.SD, function(col) {
        do.call(
          zoo::rollapply,
          c(
            list(data = col, width = rolling_window),
            dots
          )
        )
      }),
      .SDcols = cols
    ]

    topical_sent <- topical_sent[date %in% idx]
  }

  ## Prepare plot
  if (!isFALSE(plot)) {
    plot_data <- topical_sent[, lapply(.SD, nafill, type = "locf")]
    plot_data <- stats::na.omit(melt(plot_data, id.vars = "date"))

    if (plot_ridgelines) {
      plot_data <- plot_data[, list(
        date,
        value = value / max(abs(value)),
        variable
      )]

      p_topical_sent <-
        ggplot2::ggplot(
          plot_data,
          ggplot2::aes(
            date,
            height = value,
            y = variable,
            group = variable,
            fill = variable
          )
        ) +
        ggridges::geom_ridgeline(min_height = -100, scale = 1 / 2) +
        ggplot2::scale_fill_manual(values = make_colors(x, "L1")) +
        # ggplot2::scale_x_date(expand = c(0,0)) +
        ggplot2::guides(fill = "none") +
        ggplot2::ylab("Topical sentiment") +
        ggplot2::xlab("Date")
    } else {
      p_topical_sent <-
        ggplot2::ggplot(
          plot_data,
          ggplot2::aes(date, value, color = variable)
        ) +
        ggplot2::geom_line(linewidth = 1.5) +
        # ggplot2::guides(color = ggplot2::guide_legend(reverse = TRUE, title = "Topic")) +
        ggplot2::guides(color = "none") +
        ggplot2::scale_color_manual(values = make_colors(x, "L1")) +
        # ggplot2::scale_y_continuous(expand = c(0,0), labels = function(breaks) sprintf("%.f%%", breaks * 100) ) +
        ggplot2::scale_x_date(expand = c(0, 0)) +
        ggplot2::ylab("Topical sentiment") +
        ggplot2::xlab("Date") +
        ggplot2::facet_wrap(. ~ variable)
    }

    if (isTRUE(plot)) print(p_topical_sent)
  }

  if (as.xts & length(missingSuggets("xts")) == 0) {
    topical_sent <- xts::as.xts(topical_sent, dateFormat = "Date")
  }

  if (!isFALSE(plot)) {
    attr(topical_sent, "plot") <- p_topical_sent
  }

  topical_sent
}
#' @rdname sentiment_topics
#' @export
plot_sentiment_topics <- function(
  x,
  period = c("year", "quarter", "month", "day"),
  rolling_window = 1,
  scale = TRUE,
  scaling_period = c("1900-01-01", "2099-12-31"),
  plot_ridgelines = TRUE,
  ...
) {
  period <- match.arg(period)
  if (missing(plot_ridgelines) & length(missingSuggets("ggridges") > 0)) {
    plot_ridgelines <- FALSE
  }
  res <- sentiment_topics(
    x,
    period,
    rolling_window,
    scale,
    scaling_period,
    plot_ridgelines,
    plot = "silent",
    as.xts = FALSE,
    ...
  )
  attr(res, "plot")
}

#' Compute the topic or sentiment proportion time series
#'
#' @family series functions
#' @inheritParams sentiment_topics
#'
#' @param x a [LDA()], [JST()] or [rJST()] model populated with internal dates
#'   and/or internal sentiment.
#' @param complete if FALSE, only compute proportions at the upper level of the
#'   topic model hierarchy (topics for [rJST] and sentiment for [JST]). No
#'   effect on [LDA] models.
#'
#' @description Aggregate the topical or sentiment proportions at the document
#'   level into time series.
#'
#' @return A time series of proportions, stored as an [xts::xts] object or as a
#'   data.frame.
#' @export
#'
#' @seealso sentopics_sentiment sentopics_date
#' @examples
#' \donttest{lda <- LDA(ECB_press_conferences_tokens)
#' lda <- fit(lda, 100)
#' proportion_topics(lda)
#'
#' # plot shortcut
#' plot_proportion_topics(lda, period = "month", rolling_window = 3)
#' # with or without ridgelines
#' plot_proportion_topics(lda, period = "month", plot_ridgelines = FALSE)
#'
#' # also available for rJST and JST models
#' jst <- JST(ECB_press_conferences_tokens, lexicon = LoughranMcDonald)
#' jst <- fit(jst, 100)
#' # including both layers
#' proportion_topics(jst)
#' # or not
#' proportion_topics(jst, complete = FALSE)}
proportion_topics <- function(
  x,
  period = c("year", "quarter", "month", "day", "identity"),
  rolling_window = 1,
  complete = TRUE,
  plot = c(FALSE, TRUE, "silent"),
  plot_ridgelines = TRUE,
  as.xts = TRUE,
  ...
) {
  ## CMD check
  .date <- value <- variable <- prob <- NULL

  period <- match.arg(period)
  plot <- as.character(plot)
  plot <- match.arg(plot)
  plot <- as.logical(plot)

  mis <- c()
  if (rolling_window > 1) {
    mis <- c("zoo")
  }
  if (as.xts) {
    mis <- c(mis, "xts")
  }
  if (!isFALSE(plot)) {
    mis <- c(mis, "ggplot2")
  }
  if (missing(plot_ridgelines) & length(missingSuggets("ggridges") > 0)) {
    plot_ridgelines <- FALSE
  }
  if (plot_ridgelines & !isFALSE(plot)) {
    mis <- c(mis, "ggridges")
  }
  mis <- missingSuggets(mis)
  if (length(mis) > 0) {
    stop(
      "Suggested packages are missing for the proportion_topics function.\n",
      "Please install first the following packages: ",
      paste0(mis, collapse = ", "),
      ".\n",
      "Install command: install.packages(",
      paste0("'", mis, "'", collapse = ", "),
      ")"
    )
  }

  if (complete) {
    proportions <- switch(
      class(x)[1],
      LDA = {
        dcast(melt(x), .id ~ topic, value.var = "prob")
      },
      rJST = {
        dcast(melt(x), .id ~ topic + sent, value.var = "prob")
      },
      JST = {
        dcast(melt(x), .id ~ sent + topic, value.var = "prob")
      },
      stop("Undefined input")
    )
  } else {
    proportions <- switch(
      class(x)[1],
      LDA = {
        dcast(melt(x), .id ~ topic, value.var = "prob")
      },
      rJST = {
        # dcast(melt(x), .id ~ topic, value.var = "prob", fun.aggregate = sum)
        dcast(
          melt(x)[, list(prob = sum(prob)), by = c("topic", ".id")],
          .id ~ topic,
          value.var = "prob"
        )
      },
      JST = {
        # dcast(melt(x), .id ~ sent, value.var = "prob", fun.aggregate = sum)
        dcast(
          melt(x)[, list(prob = sum(prob)), by = c("sent", ".id")],
          .id ~ sent,
          value.var = "prob"
        )
      },
      stop("Undefined input")
    )
  }

  proportions <- merge(
    sentopics_date(x),
    proportions,
    by = ".id",
    sort = FALSE
  )

  ## early return
  if (period == "identity") {
    data.table::setnames(proportions, ".date", "date")
    return(proportions)
  }

  proportions <- proportions[,
    c(lapply(.SD, mean)),
    .SDcols = -c(".id", ".date"),
    by = list(date = floor_date(`.date`, period))
  ]
  proportions <- proportions[order(date)]

  ## quick check
  if (
    !isTRUE(all.equal(
      rowSums(proportions[, -c("date")]),
      rep(1, nrow(proportions))
    ))
  ) {
    stop(
      "Computation of breakdown failed. Please contact the author of the package to report the issue."
    )
  }

  if (rolling_window > 1) {
    ## Store existing dates
    idx <- proportions$date
    ## Fill empty periods
    proportions <- merge(
      data.table(
        date = seq(min(proportions$date), max(proportions$date), by = period)
      ),
      proportions,
      by = "date",
      all.x = TRUE
    )

    ## Set default parameter for rolling
    dots <- list(...)
    if (is.null(dots$FUN)) {
      dots$FUN <- mean
    }
    if (is.null(dots$na.rm)) {
      dots$na.rm <- TRUE
    }
    if (is.null(dots$fill)) {
      dots$fill <- NA
    }
    if (is.null(dots$align)) {
      dots$align <- "right"
    }

    cols <- setdiff(names(proportions), c("date"))
    proportions[,
      (cols) := lapply(.SD, function(col) {
        do.call(
          zoo::rollapply,
          c(
            list(data = col, width = rolling_window),
            dots
          )
        )
      }),
      .SDcols = cols
    ]

    proportions <- proportions[date %in% idx]
  }

  ## Prepare plot
  if (!isFALSE(plot)) {
    plot_data <- proportions[, lapply(.SD, nafill, type = "locf")]
    plot_data <- stats::na.omit(melt(plot_data, id.vars = "date"))

    if (inherits(x, "LDA") | !complete) {
      colorScope <- "L1"
    } else {
      colorScope <- c("L1", "L2")
    }

    # if (plot_ridgelines & length(missingSuggets("ggridges")) == 0) {
    if (plot_ridgelines) {
      plot_data <- plot_data[, list(
        date,
        value = value / max(abs(`value`)),
        `variable`
      )]

      p_proportions <-
        ggplot2::ggplot(
          plot_data,
          ggplot2::aes(
            date,
            height = value,
            y = variable,
            group = variable,
            fill = variable
          )
        ) +
        ggridges::geom_ridgeline(min_height = 0, scale = 1 / 1.1) +
        # ggplot2::scale_x_date(expand = c(0,0)) +
        ggplot2::scale_fill_manual(values = make_colors(x, colorScope)) +
        ggplot2::guides(fill = "none") +
        ggplot2::ylab(ifelse(
          inherits(x, "JST"),
          "Sentiment proportion",
          "Topical proportion"
        )) +
        ggplot2::xlab("Date")
    } else {
      # if (plot_ridgelines) message("Package `ggridges` is missing. Defaulting to standard ggplot.")

      # plot_data[, cum_value := cumsum(value), by = "date"]
      p_proportions <-
        ggplot2::ggplot(plot_data, ggplot2::aes(date, value, fill = variable)) +
        ggplot2::geom_area(position = ggplot2::position_stack(reverse = TRUE)) +
        # ggplot2::guides(fill = ggplot2::guide_legend(reverse = TRUE,
        #                                              title = ifelse(inherits(x, "JST"), "Sentiment", "Topic"))) +
        ggplot2::guides(fill = "none") +
        ggplot2::scale_fill_manual(values = make_colors(x, colorScope)) +
        ggplot2::scale_y_continuous(
          expand = c(0, 0),
          labels = function(breaks) sprintf("%.f%%", breaks * 100),
          limits = c(0, NA)
        ) +
        ggplot2::scale_x_date(expand = c(0, 0)) +
        ggplot2::ylab(ifelse(
          inherits(x, "JST"),
          "Sentiment proportion",
          "Topical proportion"
        )) +
        ggplot2::xlab("Date") +
        ggplot2::facet_wrap(. ~ variable)

      # for non-LDA models, draw line only at intersection between upper layer
      # labels
      ## With the update and the built-in facet wrap, the distinction no longer
      ## make sense
      # if (inherits(x, "LDA") | !complete) {
      p_proportions <- p_proportions +
        ggplot2::geom_line(position = ggplot2::position_stack(reverse = TRUE))
      # } else {
      #   tmp <- create_labels(x, flat = FALSE)
      #   tmp <- sapply(tmp$L1, paste0, "_", tmp$L2[length(tmp$L2)], USE.NAMES = FALSE)
      #   plot_data_alt <- plot_data[, list(variable, value = cumsum(value)), by = "date"]
      #   plot_data_alt <- plot_data_alt[variable %in% tmp]
      #   p_proportions <- p_proportions +
      #     ggplot2::geom_line(data = plot_data_alt)
      # }
    }

    if (isTRUE(plot)) print(p_proportions)
  }

  if (as.xts & length(missingSuggets("xts")) == 0) {
    proportions <- xts::as.xts(proportions, dateFormat = "Date")
  }

  if (!isFALSE(plot)) {
    attr(proportions, "plot") <- p_proportions
  }

  proportions
}
#' @rdname proportion_topics
#' @export
plot_proportion_topics <- function(
  x,
  period = c("year", "quarter", "month", "day"),
  rolling_window = 1,
  complete = TRUE,
  plot_ridgelines = TRUE,
  ...
) {
  period <- match.arg(period)
  if (missing(plot_ridgelines) & length(missingSuggets("ggridges") > 0)) {
    plot_ridgelines <- FALSE
  }
  res <- proportion_topics(
    x,
    period,
    rolling_window,
    complete,
    plot_ridgelines,
    plot = "silent",
    as.xts = FALSE,
    ...
  )
  attr(res, "plot")
}

#' @keywords internal
days_period <- function(date, period) {
  if (period == "day") {
    return(rep(1, length(date)))
  }
  attributes(date)
  tmp <- data.table::transpose(
    lapply(date, function(x) rev(seq(x, by = period, length.out = 2)))
  )
  for (i in seq_along(tmp)) {
    class(tmp[[i]]) <- "Date"
  }
  as.numeric(difftime(tmp[[1]], tmp[[2]]))
}

#' @keywords internal
make_colors <- function(x, dimrange = c("L1", "L2")) {
  params <- sentopicsmodel_params(x)
  if (!("L2" %in% dimrange)) {
    params$L2 <- 1L
  }
  if (params$L1 < 10) {
    cols <- unlist(lapply(
      RColorBrewer::brewer.pal(max(params$L1, 3), "Set1"),
      spreadColor,
      params$L2,
      range = .2
    ))
  } else {
    cols <- unlist(lapply(
      grDevices::colorRampPalette(RColorBrewer::brewer.pal(7, "Set1"))(
        params$L1
      ),
      spreadColor,
      params$L2,
      range = .2
    ))
  }
  cols
}

#' @keywords internal
sentopicsmodel_params <- function(x) {
  x <- as.sentopicsmodel(x)
  c(
    x[c(
      "L1",
      "L2",
      # "L1prior", "L2prior", "beta",
      "L1cycle",
      "L2cycle"
    )],
    attributes(x)[c("reverse", "Sdim")],
    L1_name = ifelse(attr(x, "reverse") == TRUE, "topic", "sentiment"),
    L2_name = ifelse(attr(x, "reverse") == FALSE, "topic", "sentiment")
  )
}