R/tsqca_report.R

Defines functions write_simple_report write_full_report verification_snippet relabel_outcome_lines report_outcome_label generate_report

Documented in generate_report write_full_report write_simple_report

###############################################
# Report generation for ThSQCA
###############################################

#' Generate Markdown Report for QCA Analysis
#'
#' Creates a markdown report from QCA analysis results.
#' Supports two formats: "full" (comprehensive) and "simple" (for manuscripts).
#'
#' @param result A result object from any Sweep function with
#'   \code{return_details = TRUE}.
#' @param output_file Character. Path to output markdown file.
#' @param format Character. Report format: \code{"full"} or \code{"simple"}.
#' @param title Character. Report title.
#' @param dat Optional data frame. Original data for descriptive statistics.
#' @param desc_vars Optional character vector. Variables for descriptive statistics.
#'   If NULL and dat is provided, uses Yvar and Xvars from params.
#' @param include_chart Logical. If TRUE (default), includes configuration charts
#'   (Fiss-style tables) in the report for each threshold.
#' @param chart_symbol_set Character. Symbol set for configuration charts:
#'   \code{"unicode"} (default), \code{"ascii"}, or \code{"latex"}.
#' @param chart_level Character. Chart aggregation level:
#'   \code{"term"} (default) produces solution-term level charts following Fiss (2011)
#'   notation, where each column represents one prime implicant (sufficient
#'   configuration). This format is recommended for academic publications.
#'   \code{"summary"} produces threshold-level summaries where each
#'   column represents one threshold, aggregating all configurations.
#' @param solution_note Logical. If TRUE (default), adds a note when multiple
#'   equivalent solutions exist explaining that M1 is shown.
#' @param solution_note_style Character. Style of solution note:
#'   \code{"simple"} (default) or \code{"detailed"} (includes EPIs).
#' @param solution_note_lang Character. Language for solution notes:
#'   \code{"en"} (default) or \code{"ja"}.
#' @param include_fiss_core Logical. If TRUE and \code{result$fiss_core} exists
#'   (i.e., \code{\link{compute_fiss_core}} has been run), the configuration
#'   charts use full Fiss (2011) four-symbol notation distinguishing core
#'   (conditions of the parsimonious term contained in each configuration)
#'   from peripheral conditions (intermediate only). If FALSE (default) or if \code{fiss_core}
#'   data is absent, the standard two-symbol chart is used.
#' @param include_raw_output Logical. If TRUE (default), includes the raw QCA
#'   package output (print(sol)) for each threshold for verification purposes.
#'
#' @return Invisibly returns the path to the generated report.
#' @export
#'
#' @examples
#' \dontrun{
#' data(sample_data)
#' thrX <- c(X1 = 7, X2 = 7, X3 = 7)
#' 
#' result <- otSweep(
#'   dat = sample_data,
#'   outcome = "Y",
#'   conditions = c("X1", "X2", "X3"),
#'   sweep_range = 6:8,
#'   thrX = thrX,
#'   return_details = TRUE
#' )
#' 
#' # With descriptive statistics and configuration charts
#' generate_report(result, "my_report.md", format = "full", 
#'                 dat = sample_data, include_chart = TRUE)
#' 
#' # Without configuration charts
#' generate_report(result, "my_report.md", format = "simple",
#'                 include_chart = FALSE)
#' 
#' # With Fiss-style term-level charts (default, recommended for publications)
#' generate_report(result, "my_report.md", format = "full")
#' 
#' # With threshold-level summary charts
#' generate_report(result, "my_report.md", format = "full",
#'                 chart_level = "summary")
#' 
#' # With Fiss core/peripheral chart (requires compute_fiss_core)
#' res_fiss <- compute_fiss_core(result, conditions = c("X1", "X2", "X3"))
#' generate_report(res_fiss, "my_report.md", format = "full",
#'                 include_fiss_core = TRUE)
#' }
generate_report <- function(result,
                            output_file = "qca_report.md",
                            format = c("full", "simple"),
                            title = "QCA Analysis Report",
                            dat = NULL,
                            desc_vars = NULL,
                            include_chart = TRUE,
                            chart_symbol_set = c("unicode", "ascii", "latex"),
                            chart_level = c("term", "summary"),
                            solution_note = TRUE,
                            solution_note_style = c("simple", "detailed"),
                            solution_note_lang = c("en", "ja"),
                            include_fiss_core = FALSE,
                            include_raw_output = TRUE) {
  
  format <- match.arg(format)
  chart_symbol_set <- match.arg(chart_symbol_set)
  chart_level <- match.arg(chart_level)
  solution_note_style <- match.arg(solution_note_style)
  solution_note_lang <- match.arg(solution_note_lang)
  
  # Resolve fiss_core availability
  use_fiss <- isTRUE(include_fiss_core) && !is.null(result$fiss_core)
  
  # Validate input
  if (!is.list(result)) {
    stop("'result' must be a list object from a Sweep function.")
  }
  
  if (!"details" %in% names(result)) {
    stop("'result' must contain 'details'. Use return_details = TRUE in Sweep functions.")
  }
  
  # Open file connection
  con <- file(output_file, open = "w", encoding = "UTF-8")
  on.exit(close(con), add = TRUE)
  
  # Write header
  writeLines(paste0("# ", title, "\n"), con)
  writeLines("*(Auto-generated by ThSQCA package)*\n", con)
  writeLines(paste0("**Generated**: ", format(Sys.time(), "%Y-%m-%d %H:%M"), "\n"), con)
  writeLines("---\n", con)
  
  # Dispatch to appropriate format
  if (format == "full") {
    write_full_report(result, con, dat, desc_vars, include_chart, chart_symbol_set,
                      chart_level, solution_note, solution_note_style, solution_note_lang,
                      include_raw_output, use_fiss)
  } else {
    write_simple_report(result, con, include_chart, chart_symbol_set,
                        chart_level, solution_note, solution_note_style, solution_note_lang,
                        include_raw_output, use_fiss)
  }
  
  message("Report generated: ", output_file)
  invisible(output_file)
}


#' Outcome label used in generated reports
#'
#' The sweeps always binarise the outcome into an internal column named
#' \code{"Y"}. Reports should show the user's own outcome name instead.
#'
#' @param params The \code{params} list of a sweep result.
#' @return Character scalar: the outcome as supplied by the user (including a
#'   leading \code{~} for negated outcomes), or \code{"Y"} if unavailable.
#' @keywords internal
#' @noRd
report_outcome_label <- function(params) {
  o <- NULL
  if (!is.null(params)) {
    o <- params$outcome
    if (is.null(o)) o <- params$Yvar
  }
  if (is.null(o) || length(o) != 1L || is.na(o) || !nzchar(o)) return("Y")
  as.character(o)
}

#' Replace the internal outcome name in QCA console output
#'
#' Rewrites the trailing \code{-> Y} (or \code{-> ~Y}) of QCA solution lines
#' so that the raw QCA output pasted into a report uses the user's outcome name.
#'
#' @param lines Character vector (captured console output).
#' @param label Outcome label from \code{report_outcome_label()}.
#' @return Character vector.
#' @keywords internal
#' @noRd
relabel_outcome_lines <- function(lines, label) {
  if (identical(label, "Y")) return(lines)
  lab_esc <- gsub("\\\\", "\\\\\\\\", label)
  sub("->\\s*~?Y(\\s*)$", paste0("-> ", lab_esc, "\\1"), lines)
}

#' R code snippet for verifying a report with the QCA package
#'
#' @param params The \code{params} list of a sweep result (may be NULL).
#' @return Character vector of code lines.
#' @keywords internal
#' @noRd
verification_snippet <- function(params) {
  outcome <- sub("^~", "", report_outcome_label(params))
  conds <- params$conditions
  if (is.null(conds)) conds <- params$Xvars
  conds_str <- if (!is.null(conds) && length(conds) > 0L) {
    paste0("c(", paste0("\"", conds, "\"", collapse = ", "), ")")
  } else {
    "c(...)"
  }
  incl <- if (!is.null(params$incl.cut)) params$incl.cut else 0.8
  # Reproduce the solution type that was actually used.
  min_call <- if (!is.null(params$dir.exp)) {
    paste0("sol <- minimize(tt, include = \"?\", dir.exp = c(",
           paste(unname(params$dir.exp), collapse = ", "), "))")
  } else if (!is.null(params$include) && nzchar(params$include)) {
    paste0("sol <- minimize(tt, include = \"", params$include, "\")")
  } else {
    "sol <- minimize(tt)"
  }
  c(
    "library(QCA)",
    "# dat_bin: your data with the outcome and conditions binarised at the thresholds of interest",
    paste0("tt <- truthTable(dat_bin, outcome = \"", outcome, "\", conditions = ",
           conds_str, ", incl.cut = ", incl, ")"),
    min_call,
    "print(sol)  # Compare with ThSQCA output above"
  )
}

#' Write full report content
#' @keywords internal
write_full_report <- function(result, con, dat = NULL, desc_vars = NULL,
                              include_chart = TRUE, chart_symbol_set = "unicode",
                              chart_level = "term",
                              solution_note = TRUE, solution_note_style = "simple",
                              solution_note_lang = "en",
                              include_raw_output = TRUE,
                              use_fiss = FALSE) {
  
  summary_df <- result$summary
  details <- result$details
  params <- result$params
  outcome_lab <- report_outcome_label(params)
  
  # ============================================
  # 0. Analysis Overview
  # ============================================
  writeLines("## 0. Analysis Overview\n", con)
  writeLines("| Item | Value |", con)
  writeLines("|------|-------|", con)
  writeLines(paste0("| Analysis Date | ", format(Sys.time(), "%Y-%m-%d %H:%M"), " |"), con)
  
  if (!is.null(dat)) {
    writeLines(paste0("| Total N | ", nrow(dat), " |"), con)
  }
  
  if (!is.null(params)) {
    # Support both old (Yvar/Xvars) and new (outcome/conditions) parameter names
    outcome_var <- params$outcome
    if (is.null(outcome_var)) outcome_var <- params$Yvar
    conditions_var <- params$conditions
    if (is.null(conditions_var)) conditions_var <- params$Xvars
    
    if (!is.null(outcome_var)) {
      outcome_display <- outcome_var
      if (isTRUE(params$negate_outcome)) {
        outcome_display <- paste0(outcome_var, " (negated)")
      }
      writeLines(paste0("| Outcome Variable | ", outcome_display, " |"), con)
    }
    if (!is.null(conditions_var)) {
      writeLines(paste0("| Condition Variables | ", paste(conditions_var, collapse = ", "), " |"), con)
    }
    if (!is.null(params$pre_calibrated)) {
      pc_str <- paste(params$pre_calibrated, collapse = ", ")
      writeLines(paste0("| Pre-Calibrated Conditions | ", pc_str, " (passed through, no binarization) |"), con)
    }
    if (!is.null(params$thrX)) {
      thrX_str <- paste(names(params$thrX), params$thrX, sep = "=", collapse = ", ")
      writeLines(paste0("| X Thresholds | ", thrX_str, " |"), con)
    }
    if (!is.null(params$sweep_range)) {
      writeLines(paste0("| Y Sweep Range | ", min(params$sweep_range), "-", max(params$sweep_range), " |"), con)
    }
    if (!is.null(params$thrY)) {
      writeLines(paste0("| Y Threshold | ", params$thrY, " |"), con)
    }
    if (!is.null(params$incl.cut)) {
      writeLines(paste0("| Consistency Cutoff | ", params$incl.cut, " |"), con)
    }
    if (!is.null(params$n.cut)) {
      writeLines(paste0("| Frequency Cutoff (n.cut) | ", params$n.cut, " |"), con)
    }
    if (!is.null(params$include)) {
      writeLines(paste0("| Include | ", params$include, " |"), con)
    }
    if (!is.null(params$dir.exp)) {
      dir_str <- ifelse(all(params$dir.exp == 1), "positive (all)", 
                        paste(params$dir.exp, collapse = ", "))
      writeLines(paste0("| Directional Expectations | ", dir_str, " |"), con)
    }
    # Solution Type (determined from include and dir.exp)
    solution_type <- if (is.null(params$include) || params$include == "") {
      "Complex (Conservative)"
    } else if (!is.null(params$dir.exp)) {
      "Intermediate"
    } else {
      "Parsimonious"
    }
    writeLines(paste0("| **Solution Type** | **", solution_type, "** |"), con)
  }
  writeLines("\n---\n", con)
  
  # ============================================
  # 1. Descriptive Statistics (if dat provided)
  # ============================================
  if (!is.null(dat)) {
    writeLines("## 1. Descriptive Statistics\n", con)
    
    # Determine variables (support both old and new parameter names)
    if (is.null(desc_vars) && !is.null(params)) {
      outcome_var <- params$outcome
      if (is.null(outcome_var)) outcome_var <- params$Yvar
      conditions_var <- params$conditions
      if (is.null(conditions_var)) conditions_var <- params$Xvars
      
      # For negated outcome, use the cleaned variable name
      if (!is.null(outcome_var)) {
        outcome_clean <- sub("^~", "", outcome_var)
        desc_vars <- c(outcome_clean, conditions_var)
      } else {
        desc_vars <- conditions_var
      }
    }
    
    if (!is.null(desc_vars)) {
      desc_df <- data.frame(
        Variable = character(0),
        n = integer(0),
        Mean = numeric(0),
        SD = numeric(0),
        Min = numeric(0),
        Max = numeric(0),
        Skew = numeric(0),
        Kurtosis = numeric(0),
        stringsAsFactors = FALSE
      )
      
      for (var in desc_vars) {
        if (var %in% names(dat)) {
          x <- dat[[var]]
          x <- x[!is.na(x)]
          n <- length(x)
          m <- mean(x)
          s <- sd(x)
          
          # Skewness
          skew <- if (n > 2 && s > 0) {
            sum((x - m)^3) / (n * s^3)
          } else {
            NA
          }
          
          # Kurtosis (excess)
          kurt <- if (n > 3 && s > 0) {
            sum((x - m)^4) / (n * s^4) - 3
          } else {
            NA
          }
          
          desc_df <- rbind(desc_df, data.frame(
            Variable = var,
            n = n,
            Mean = round(m, 3),
            SD = round(s, 3),
            Min = round(min(x), 3),
            Max = round(max(x), 3),
            Skew = round(skew, 3),
            Kurtosis = round(kurt, 3),
            stringsAsFactors = FALSE
          ))
        }
      }
      
      if (nrow(desc_df) > 0) {
        writeLines(df_to_md_table(desc_df), con)
      }
    }
    writeLines("\n---\n", con)
  }
  
  # ============================================
  # 2. Summary Table
  # ============================================
  section_num <- if (!is.null(dat)) 2 else 1
  writeLines(paste0("## ", section_num, ". Summary Table\n"), con)
  writeLines(df_to_md_table(summary_df), con)
  writeLines("\n---\n", con)
  
  # ============================================
  # 3. Detailed Results per Threshold
  # ============================================
  section_num <- section_num + 1
  writeLines(paste0("## ", section_num, ". Detailed Results\n"), con)
  
  # Limit detailed output to avoid extremely long reports
  n_combinations <- length(details)
  MAX_DETAILS <- 27
  
  if (n_combinations > MAX_DETAILS) {
    writeLines(paste0("Due to the large number of threshold combinations (", 
                      n_combinations, "), detailed per-threshold results ",
                      "(necessity analysis, truth tables, per-term metrics) ",
                      "are omitted from this report.\n"), con)
    writeLines("", con)
    writeLines("To access details for specific threshold combinations, use:\n", con)
    writeLines("```r", con)
    writeLines("# List all threshold combinations", con)
    writeLines("names(result$details)", con)
    writeLines("", con)
    writeLines("# Access a specific combination (e.g., first one)", con)
    writeLines("key <- names(result$details)[1]", con)
    writeLines("det <- result$details[[key]]", con)
    writeLines("", con)
    writeLines("# Available components:", con)
    writeLines("det$truth_table$tt   # Truth table", con)
    writeLines("det$solution         # QCA solution object", con)
    writeLines("det$dat_bin          # Binarized data (for necessity analysis with QCA::pofind)", con)
    writeLines("det$thrX_vec         # X thresholds used", con)
    writeLines("det$thrY             # Y threshold used", con)
    writeLines("```\n", con)
  } else {
  
  for (key in names(details)) {
    det <- details[[key]]
    
    # Determine threshold label
    if (!is.null(det$thrY)) {
      writeLines(paste0("### thrY = ", det$thrY, "\n"), con)
    } else if (!is.null(det$threshold)) {
      writeLines(paste0("### Threshold = ", det$threshold, "\n"), con)
    } else if (!is.null(det$combo_id)) {
      writeLines(paste0("### Combination ", det$combo_id, "\n"), con)
    } else {
      writeLines(paste0("### ", key, "\n"), con)
    }
    
    # X thresholds
    if (!is.null(det$thrX_vec)) {
      thrX_str <- paste(names(det$thrX_vec), det$thrX_vec, sep = "=", collapse = ", ")
      writeLines(paste0("**X Thresholds**: ", thrX_str, "\n"), con)
    }
    
    # ---- Necessity Analysis ----
    dat_bin <- det$dat_bin
    if (!is.null(dat_bin) && !is.null(det$thrX_vec)) {
      Xvars <- names(det$thrX_vec)
      nec <- quiet_try(QCA::pofind(dat_bin, outcome = "Y", conditions = Xvars), silent = TRUE)
      if (!inherits(nec, "try-error") && !is.null(nec$incl.cov)) {
        writeLines("#### Necessity Analysis\n", con)
        nec_df <- nec$incl.cov
        nec_df <- cbind(Condition = trimws(rownames(nec_df)), nec_df)
        rownames(nec_df) <- NULL
        writeLines(df_to_md_table(nec_df), con)
        writeLines("\n", con)
      }
    }
    
    # ---- Truth Table ----
    tt <- det$truth_table
    if (!is.null(tt) && !is.null(tt$tt)) {
      writeLines("#### Truth Table (observed configurations)\n", con)
      tt_df <- tt$tt
      tt_observed <- tt_df[tt_df$n > 0, , drop = FALSE]
      if (nrow(tt_observed) > 0) {
        tt_cols <- intersect(c(names(det$thrX_vec), "OUT", "n", "incl", "PRI"), names(tt_observed))
        tt_subset <- tt_observed[, tt_cols, drop = FALSE]
        tt_subset <- cbind(Row = rownames(tt_subset), tt_subset)
        rownames(tt_subset) <- NULL
        writeLines(df_to_md_table(tt_subset), con)
      } else {
        writeLines("*(No observed configurations)*", con)
      }
      writeLines("\n", con)
    }
    
    # ---- Solution ----
    sol <- det$solution
    if (is.null(sol)) {
      writeLines("#### Solution\n", con)
      writeLines("**No solution**\n", con)
    } else {
      n_sol <- get_n_solutions(sol)
      writeLines("#### Solution\n", con)
      writeLines(paste0("**Number of Solutions**: ", n_sol, "\n"), con)
      
      # Get solution list (i.sol first for true Intermediate when dir.exp
      # specified). Deduplicated across prime implicant charts; see
      # collect_unique_i_sol() for why naive concatenation double-counts.
      sol_list <- collect_unique_i_sol(sol)

      if (!is.null(sol_list) && length(sol_list) > 0) {
        writeLines("**Full Solutions**:\n", con)
        for (i in seq_along(sol_list)) {
          expr <- paste(sol_list[[i]], collapse = " + ")
          writeLines(paste0("- M", i, ": ", escape_md(expr), " -> ", outcome_lab, "\n"), con)
        }
        writeLines("\n", con)
        
        # Essential/Selective Prime Implicants (if multiple solutions)
        if (length(sol_list) > 1) {
          sol_terms <- lapply(sol_list, function(x) {
            if (is.character(x)) x else unlist(strsplit(paste(x, collapse = " + "), " \\+ "))
          })
          essential_terms <- Reduce(intersect, sol_terms)
          all_terms <- Reduce(union, sol_terms)
          selective_terms <- setdiff(all_terms, essential_terms)
          
          if (length(essential_terms) > 0) {
            writeLines(paste0("**Essential Prime Implicants**: ", 
                              escape_md(paste(essential_terms, collapse = " + ")), "\n"), con)
          } else {
            writeLines("**Essential Prime Implicants**: (none - solutions are disjoint)\n", con)
          }
          
          if (length(selective_terms) > 0) {
            writeLines(paste0("**Selective Prime Implicants**: ", 
                              escape_md(paste(selective_terms, collapse = " + ")), "\n"), con)
          }
          
          # Unique Terms
          unique_terms_list <- lapply(seq_along(sol_terms), function(i) {
            other_terms <- unique(unlist(sol_terms[-i]))
            setdiff(sol_terms[[i]], other_terms)
          })
          unique_terms_formatted <- sapply(seq_along(unique_terms_list), function(i) {
            if (length(unique_terms_list[[i]]) > 0) {
              paste0("M", i, ": ", escape_md(paste(unique_terms_list[[i]], collapse = " + ")))
            } else {
              NULL
            }
          })
          unique_terms_filtered <- unique_terms_formatted[!sapply(unique_terms_formatted, is.null)]
          if (length(unique_terms_filtered) > 0) {
            writeLines(paste0("**Unique Terms**: ", 
                              paste(unique_terms_filtered, collapse = "; "), "\n"), con)
          }
          writeLines("\n", con)
        }
      }
      
      # ---- Solution Fit ----
      writeLines("#### Solution Fit\n", con)
      # Report the fit of the DISPLAYED solution. When dir.exp yields an
      # intermediate solution, its fit lives in sol$i.sol$C1P1$IC; sol$IC
      # describes the parsimonious solution and must not be used here. This
      # mirrors the intermediate-aware call further below.
      ic_for_metrics <- if (!is.null(sol$i.sol) && length(sol$i.sol) > 0 &&
                            !is.null(sol$i.sol$C1P1$IC)) {
        sol$i.sol$C1P1$IC
      } else {
        sol$IC
      }
      metrics <- extract_all_metrics(ic_for_metrics, sol)
      writeLines("| Metric | Value |", con)
      writeLines("|--------|-------|", con)
      writeLines(paste0("| Consistency (inclS) | ", 
                        ifelse(is.na(metrics$sol_inclS), "N/A", round(metrics$sol_inclS, 3)), " |"), con)
      writeLines(paste0("| PRI | ", 
                        ifelse(is.na(metrics$sol_PRI), "N/A", round(metrics$sol_PRI, 3)), " |"), con)
      writeLines(paste0("| Coverage (covS) | ", 
                        ifelse(is.na(metrics$sol_covS), "N/A", round(metrics$sol_covS, 3)), " |"), con)
      writeLines("\n", con)
      
      # ---- Per-Term Metrics ----
      if (!is.null(metrics$term_df)) {
        writeLines("#### Per-Term Metrics\n", con)
        term_df <- metrics$term_df
        if ("cases" %in% names(term_df)) {
          term_df <- term_df[, !names(term_df) %in% "cases", drop = FALSE]
        }
        term_df <- cbind(Term = rownames(term_df), term_df)
        rownames(term_df) <- NULL
        writeLines(df_to_md_table(term_df), con)
        writeLines("\n", con)
      }
      
      # ---- Configuration Chart ----
      if (include_chart && !is.null(sol_list) && length(sol_list) > 0) {
        writeLines("#### Configuration Chart\n", con)
        
        # Fiss 4-symbol chart (per-threshold)
        thr_key <- as.character(key)
        if (use_fiss && !is.null(result$fiss_core[[thr_key]])) {
          fc <- result$fiss_core[[thr_key]]
          if (!is.null(fc$classification)) {
            writeLines(paste0(
              "*Fiss (2011) notation: core conditions (conditions of a parsimonious ",
              "term contained in the configuration) are shown with large symbols; ",
              "peripheral conditions (intermediate only) with small symbols.*\n"
            ), con)
            writeLines(paste0(
              "- Parsimonious: `", fc$parsim_expression, "`\n"
            ), con)
            writeLines(paste0(
              "- Intermediate: `", fc$interm_expression, "`\n\n"
            ), con)
            
            conditions <- result$params$conditions
            interm_terms <- unique(fc$classification$term_expr)
            symbols_fiss <- SYMBOL_SETS_FISS[[chart_symbol_set]]
            thr_label <- fiss_threshold_label(result, thr_key)
            
            mat <- build_fiss_matrix(
              interm_terms   = interm_terms,
              classification = fc$classification,
              conditions     = conditions,
              symbols        = symbols_fiss,
              thr_label      = thr_label
            )
            table_str <- config_matrix_to_md(mat, "Condition")
            legend <- if (solution_note_lang == "ja") symbols_fiss$note_ja else symbols_fiss$note_en
            writeLines(paste0(table_str, "\n\n*", legend, "*\n"), con)
          } else {
            writeLines("*No solution at this threshold.*\n", con)
          }
        } else {
          # Standard 2-symbol chart
          paths <- sol_list[[1]]
          if (!is.character(paths)) paths <- as.character(paths)
          
          if (length(paths) > 0) {
            epi_list <- NULL
            if (solution_note_style == "detailed" && length(sol_list) > 1) {
              epi_info <- identify_epi(sol_list)
              epi_list <- epi_info$epi
            }
            chart <- config_chart_from_paths(
              paths,
              symbol_set = chart_symbol_set,
              language = solution_note_lang,
              n_sol = length(sol_list),
              solution_note = solution_note,
              solution_note_style = solution_note_style,
              epi_list = epi_list
            )
            writeLines(chart, con)
            writeLines("\n", con)
          }
        }
      }
      
      # ---- QCA Package Output (for verification) ----
      if (include_raw_output) {
        writeLines("#### QCA Package Output (for verification)\n", con)
        writeLines("```", con)
        raw_output <- relabel_outcome_lines(capture.output(print(sol)), outcome_lab)
        writeLines(raw_output, con)
        writeLines("```\n", con)
      }
    }
    
    # ---- Settings for Reproducibility ----
    writeLines("#### Settings (for reproducibility)\n", con)
    writeLines("```", con)
    if (!is.null(det$thrX_vec)) {
      writeLines(paste0("thrX: ", paste(det$thrX_vec, collapse = ", ")), con)
    }
    if (!is.null(det$thrY)) {
      writeLines(paste0("thrY: ", det$thrY), con)
    }
    if (!is.null(params$incl.cut)) {
      writeLines(paste0("incl.cut: ", params$incl.cut), con)
    }
    if (!is.null(params$dir.exp)) {
      writeLines(paste0("dir.exp: ", paste(params$dir.exp, collapse = ", ")), con)
    }
    writeLines("```\n", con)
    
    writeLines("---\n", con)
  }
  
  }  # End of if (n_combinations <= MAX_DETAILS)
  
  # ============================================
  # 4. Cross-Threshold Comparison
  # ============================================
  section_num <- section_num + 1
  writeLines(paste0("## ", section_num, ". Cross-Threshold Comparison\n"), con)
  
  if (n_combinations > MAX_DETAILS) {
    writeLines("Cross-threshold comparison table is designed for single-dimension sweeps ", con)
    writeLines("(otSweep, ctSweepS) with a smaller number of thresholds.\n", con)
    writeLines("", con)
    writeLines("For multi-dimensional sweeps with many combinations, ", con)
    writeLines("please refer to the Summary Table above to compare results across threshold settings.\n", con)
  } else {
  
  # Build comparison table
  comp_df <- data.frame(
    Threshold = character(0),
    inclS = numeric(0),
    PRI = numeric(0),
    covS = numeric(0),
    n_solutions = integer(0),
    N_Essential = integer(0),
    stringsAsFactors = FALSE
  )
  
  for (key in names(details)) {
    det <- details[[key]]
    sol <- det$solution
    
    # Threshold label
    thr_label <- if (!is.null(det$thrY)) {
      paste0("thrY=", det$thrY)
    } else if (!is.null(det$threshold)) {
      as.character(det$threshold)
    } else {
      key
    }
    
    if (is.null(sol)) {
      comp_df <- rbind(comp_df, data.frame(
        Threshold = thr_label,
        inclS = NA,
        PRI = NA,
        covS = NA,
        n_solutions = 0,
        N_Essential = 0,
        stringsAsFactors = FALSE
      ))
    } else {
      # Report the fit of the DISPLAYED solution (intermediate when dir.exp is
      # used); sol$IC is the parsimonious solution and would misreport it.
      ic_for_metrics <- if (!is.null(sol$i.sol) && length(sol$i.sol) > 0 &&
                            !is.null(sol$i.sol$C1P1$IC)) {
        sol$i.sol$C1P1$IC
      } else {
        sol$IC
      }
      metrics <- extract_all_metrics(ic_for_metrics, sol)
      n_sol <- get_n_solutions(sol)
      
      # Count essential prime implicants (i.sol first for true Intermediate).
      # Deduplicated across prime implicant charts; see collect_unique_i_sol().
      n_essential <- 0
      sol_list <- collect_unique_i_sol(sol)
      if (!is.null(sol_list) && length(sol_list) > 1) {
        sol_terms <- lapply(sol_list, function(x) {
          if (is.character(x)) x else unlist(strsplit(paste(x, collapse = " + "), " \\+ "))
        })
        essential_terms <- Reduce(intersect, sol_terms)
        n_essential <- length(essential_terms)
      } else if (!is.null(sol_list) && length(sol_list) == 1) {
        n_essential <- length(sol_list[[1]])
      }
      
      comp_df <- rbind(comp_df, data.frame(
        Threshold = thr_label,
        inclS = round(metrics$sol_inclS, 3),
        PRI = round(metrics$sol_PRI, 3),
        covS = round(metrics$sol_covS, 3),
        n_solutions = n_sol,
        N_Essential = n_essential,
        stringsAsFactors = FALSE
      ))
    }
  }
  
  writeLines(df_to_md_table(comp_df), con)
  
  }  # End of if (n_combinations <= MAX_DETAILS) for Section 4
  
  writeLines("\n---\n", con)
  
  # ============================================
  # 5. Cross-Threshold Configuration Chart
  # ============================================
  if (include_chart && n_combinations <= MAX_DETAILS) {
    section_num <- section_num + 1
    writeLines(paste0("## ", section_num, ". Cross-Threshold Configuration Chart\n"), con)
    
    # Get conditions from params
    conditions <- params$conditions
    if (is.null(conditions)) conditions <- params$Xvars
    
    if (!is.null(conditions) && length(conditions) > 0) {
      
      if (use_fiss) {
        # --- Fiss 4-symbol cross-threshold chart ---
        writeLines(paste0(
          "*Fiss (2011) four-symbol notation. ",
          "Large symbols (\u25CF/\u2297) = core conditions (from the parsimonious term contained in the configuration). ",
          "Small symbols (\u2299/\u2298) = peripheral conditions (intermediate only). ",
          "Blank = don't care.*\n\n"
        ), con)
        chart <- generate_fiss_chart(
          result,
          conditions = conditions,
          symbol_set = chart_symbol_set,
          language   = solution_note_lang
        )
        writeLines(chart, con)
      } else {
        # --- Standard 2-symbol cross-threshold chart ---
        if (chart_level == "term") {
          writeLines("*Configuration chart at solution-term level (Fiss, 2011 notation).*\n", con)
          writeLines("*Each column represents one prime implicant (configuration).*\n\n", con)
        } else {
          writeLines("*Configuration chart at threshold-level summary.*\n", con)
          writeLines("*Each column aggregates all conditions that appear in any configuration at that threshold.*\n\n", con)
        }
        
        symbols <- SYMBOL_SETS[[chart_symbol_set]]
        chart <- if (chart_level == "term") {
          generate_term_level_chart(summary_df, conditions, symbols, solution_note_lang)
        } else {
          generate_threshold_level_chart(summary_df, conditions, symbols, solution_note_lang)
        }
        writeLines(chart, con)
      }
    } else {
      writeLines("*(Could not generate configuration chart - conditions not found)*\n", con)
    }
    
    writeLines("\n---\n", con)
  }
  
  # ============================================
  # 6. Notes
  # ============================================
  section_num <- section_num + 1
  writeLines(paste0("## ", section_num, ". Notes\n"), con)
  writeLines("- **Essential Prime Implicants (EPI)**: Terms that appear in ALL equivalent solutions (M1, M2, M3...).", con)
  writeLines("- **Selective Prime Implicants (SPI)**: Terms that appear in some but not all solutions.", con)
  writeLines("- **Unique Terms**: Terms that appear only in one specific solution.", con)
  writeLines("- **inclS**: Solution consistency (sufficiency).", con)
  writeLines("- **covS**: Solution coverage.", con)
  writeLines("- **PRI**: Proportional Reduction in Inconsistency.", con)
  writeLines("- **covU**: Unique coverage (coverage by this term alone).", con)
  writeLines("- **inclN**: Necessity consistency (>= 0.9 typically indicates necessary condition).", con)
  writeLines("- **RoN**: Relevance of Necessity.", con)
  writeLines("- **covN**: Necessity coverage.", con)
  if (use_fiss) {
    writeLines("", con)
    writeLines("**Fiss (2011) Core/Peripheral Classification:**", con)
    writeLines("- **Core condition** (\u25CF/\u2297): Belongs to a parsimonious term contained in the configuration (Fiss, 2011).", con)
    writeLines("- **Peripheral condition** (\u2299/\u2298): Any other condition of the configuration; it appears in the intermediate solution only.", con)
    writeLines("- Reference: Fiss, P. C. (2011). Building better causal theories: A fuzzy set approach to typologies in organization research. *Academy of Management Journal*, 54(2), 393-420.", con)
  }
  
  writeLines("\n---\n", con)
  
  # ============================================
  # 7. Verification Recommendation
  # ============================================
  section_num <- section_num + 1
  writeLines(paste0("## ", section_num, ". Verification Recommendation\n"), con)
  writeLines("**For academic publications**, always verify ThSQCA results directly with the QCA package:\n", con)
  writeLines("```r", con)
  writeLines(verification_snippet(params), con)
  writeLines("```\n", con)
  writeLines("Ensure that solution expressions, consistency, and coverage values match before publishing.", con)
  writeLines("\n", con)
  writeLines("*Report generated by ThSQCA package (https://github.com/im-research-yt/ThSQCA)*", con)
}


#' Write simple report content
#' @keywords internal
write_simple_report <- function(result, con, include_chart = TRUE, 
                                chart_symbol_set = "unicode",
                                chart_level = "term",
                                solution_note = TRUE, solution_note_style = "simple",
                                solution_note_lang = "en",
                                include_raw_output = TRUE,
                                use_fiss = FALSE) {
  
  summary_df <- result$summary
  details <- result$details
  outcome_lab <- report_outcome_label(result$params)
  
  # 1. Summary Table
  writeLines("## Summary\n", con)
  writeLines(df_to_md_table(summary_df), con)
  writeLines("\n", con)
  writeLines("---\n", con)
  
  # 2. Solutions Overview
  writeLines("## Solutions Overview\n", con)
  
  for (key in names(details)) {
    det <- details[[key]]
    sol <- det$solution
    
    if (is.null(sol)) next
    
    # Determine threshold label
    if (!is.null(det$thrY)) {
      label <- paste0(sub("^~", "", outcome_lab), " >= ", det$thrY)
    } else if (!is.null(det$threshold)) {
      label <- paste0("threshold = ", det$threshold)
    } else {
      label <- key
    }
    
    n_sol <- get_n_solutions(sol)
    
    # Get solution list (i.sol first for true Intermediate when dir.exp
    # specified). Deduplicated across prime implicant charts; see
    # collect_unique_i_sol() for why naive concatenation double-counts.
    sol_list <- collect_unique_i_sol(sol)
    
    if (!is.null(sol_list) && length(sol_list) > 0) {
      writeLines(paste0("### ", label, "\n"), con)
      
      # Show solution formula
      if (length(sol_list) == 1) {
        expr <- paste(sol_list[[1]], collapse = " + ")
        writeLines(paste0("**Solution**: ", escape_md(expr), " -> ", outcome_lab, "\n"), con)
      } else {
        writeLines(paste0("**Number of Solutions**: ", length(sol_list), "\n"), con)
        
        # Essential prime implicants
        sol_terms <- lapply(sol_list, function(x) {
          if (is.character(x)) x else unlist(strsplit(paste(x, collapse = " + "), " \\+ "))
        })
        essential_terms <- Reduce(intersect, sol_terms)
        
        if (length(essential_terms) > 0) {
          writeLines(paste0("**Essential (EPI)**: ", escape_md(paste(essential_terms, collapse = " + ")), "\n"), con)
        }
        
        # List all solutions briefly
        for (i in seq_along(sol_list)) {
          expr <- paste(sol_list[[i]], collapse = " + ")
          writeLines(paste0("- M", i, ": ", escape_md(expr), "\n"), con)
        }
      }
      
      # Metrics (brief)
      metrics <- extract_all_metrics(sol$i.sol$C1P1$IC, sol)
      writeLines(paste0("*inclS = ", 
                        ifelse(is.na(metrics$sol_inclS), "N/A", round(metrics$sol_inclS, 3)),
                        ", covS = ",
                        ifelse(is.na(metrics$sol_covS), "N/A", round(metrics$sol_covS, 3)),
                        "*\n"), con)
      
      # ---- Configuration Chart ----
      if (include_chart) {
        writeLines("\n**Configuration Chart:**\n", con)
        
        thr_key <- as.character(key)
        if (use_fiss && !is.null(result$fiss_core[[thr_key]])) {
          fc <- result$fiss_core[[thr_key]]
          if (!is.null(fc$classification)) {
            writeLines(paste0(
              "*Fiss (2011) notation. ",
              "Parsimonious: `", fc$parsim_expression, "` / ",
              "Intermediate: `", fc$interm_expression, "`*\n\n"
            ), con)
            conditions <- result$params$conditions
            interm_terms <- unique(fc$classification$term_expr)
            symbols_fiss <- SYMBOL_SETS_FISS[[chart_symbol_set]]
            thr_label <- fiss_threshold_label(result, thr_key)
            mat <- build_fiss_matrix(
              interm_terms   = interm_terms,
              classification = fc$classification,
              conditions     = conditions,
              symbols        = symbols_fiss,
              thr_label      = thr_label
            )
            table_str <- config_matrix_to_md(mat, "Condition")
            legend <- if (solution_note_lang == "ja") symbols_fiss$note_ja else symbols_fiss$note_en
            writeLines(paste0(table_str, "\n\n*", legend, "*\n"), con)
          }
        } else {
          paths <- sol_list[[1]]
          if (!is.character(paths)) paths <- as.character(paths)
          if (length(paths) > 0) {
            epi_list <- NULL
            if (solution_note_style == "detailed" && length(sol_list) > 1) {
              epi_info <- identify_epi(sol_list)
              epi_list <- epi_info$epi
            }
            chart <- config_chart_from_paths(
              paths,
              symbol_set = chart_symbol_set,
              language = solution_note_lang,
              n_sol = length(sol_list),
              solution_note = solution_note,
              solution_note_style = solution_note_style,
              epi_list = epi_list
            )
            writeLines(chart, con)
          }
        }
      }
      
      # ---- QCA Package Output (for verification) ----
      if (include_raw_output) {
        writeLines("\n**QCA Package Output (for verification):**\n", con)
        writeLines("```", con)
        raw_output <- relabel_outcome_lines(capture.output(print(sol)), outcome_lab)
        writeLines(raw_output, con)
        writeLines("```\n", con)
      }
      
      writeLines("\n", con)
    }
  }
  
  # ============================================
  # Verification Recommendation
  # ============================================
  writeLines("---\n", con)
  writeLines("## Verification Recommendation\n", con)
  writeLines("**For academic publications**, always verify ThSQCA results directly with the QCA package:\n", con)
  writeLines("```r", con)
  writeLines(verification_snippet(result$params), con)
  writeLines("```\n", con)
  writeLines("Ensure that solution expressions, consistency, and coverage values match before publishing.", con)
  writeLines("\n", con)
  writeLines("*Report generated by ThSQCA package (https://github.com/im-research-yt/ThSQCA)*", con)
}

Try the ThSQCA package in your browser

Any scripts or data that you put into this service are public.

ThSQCA documentation built on Sept. 26, 2026, 5:07 p.m.