check_app_packages <- function() {
required <- c("shiny", "haven", "QCA", "openxlsx", "DT", "readxl")
installed <- rownames(installed.packages())
missing <- setdiff(required, installed)
if (length(missing) > 0) {
stop(
"Faltan paquetes. Ejecuta en R:\n",
"install.packages(c(",
paste(sprintf('"%s"', missing), collapse = ", "),
"))",
call. = FALSE
)
}
if ("admisc" %in% installed && packageVersion("admisc") <= "0.39") {
stop(
"El paquete QCA necesita una version mas reciente de admisc.\n",
"Ejecuta en R:\n",
'install.packages("admisc")',
call. = FALSE
)
}
}
check_app_packages()
library(shiny)
library(haven)
library(QCA)
library(openxlsx)
library(DT)
library(readxl)
`%||%` <- function(x, y) {
if (is.null(x) || length(x) == 0) y else x
}
truthy <- function(x) {
if (is.null(x) || length(x) == 0 || is.na(x)) return(FALSE)
isTRUE(x) || tolower(as.character(x)) %in% c("true", "1", "yes", "si", "sí")
}
steps <- data.frame(
id = 1:8,
short = c("Datos", "Modelo", "Calibración", "Necesidad", "Tablas de la verdad", "Soluciones", "Reporte", "Robustez"),
title = c(
"1. Cargar datos",
"2. Modelizar",
"3. Explorar y calibrar",
"4. Analizar necesidad",
"5. Construir tablas de la verdad",
"6. Minimizar soluciones",
"7. Reporte y replicación",
"8. Robustez opcional"
),
stringsAsFactors = FALSE
)
welcome_step_title <- "Bienvenida"
safe_num <- function(x) {
if (inherits(x, "labelled")) x <- haven::zap_labels(x)
suppressWarnings(as.numeric(x))
}
compact_num <- function(x, digits = 3) {
ifelse(is.na(x), NA_character_, format(round(as.numeric(x), digits), nsmall = digits, trim = TRUE))
}
fmt3 <- function(x) {
compact_num(x, 3)
}
fmt_anchors <- function(x) {
paste(fmt3(x), collapse = ", ")
}
calibration_method_label <- function(x) {
switch(
x,
fuzzy_raw = "Valor original (sin calibrar)",
fuzzy_direct = "Valor original calibrado",
fuzzy_calibrated = "Fuzzy calibrado (0-1)",
crisp_binary = "Binario (0/1)",
crisp_threshold = "Binario por punto de corte",
crisp_threshold_multi = "Multivalor por puntos de corte",
crisp_multivalue = "Multivalor / categórico",
x %||% ""
)
}
first_non_na <- function(x) {
y <- x[!is.na(x) & x != ""]
if (length(y) == 0) return(NA)
y[1]
}
collapse_unique <- function(x) {
x <- unique(as.character(x[!is.na(x) & x != ""]))
if (length(x) == 0) return(NA_character_)
paste(x, collapse = " | ")
}
parse_thresholds_free <- function(txt) {
if (is.null(txt) || !nzchar(trimws(txt))) return(numeric(0))
parts <- unlist(strsplit(gsub(";", ",", txt, fixed = TRUE), ",", fixed = TRUE))
vals <- suppressWarnings(as.numeric(trimws(parts[nzchar(trimws(parts))])))
sort(unique(vals[!is.na(vals)]))
}
safe_label_text <- function(x) {
if (is.null(x) || length(x) == 0) return("")
x <- unlist(x, use.names = FALSE)
if (length(x) == 0) return("")
x <- as.character(x)
x <- unique(x[!is.na(x) & nzchar(x)])
if (length(x) == 0) return("")
paste(x, collapse = " | ")
}
read_uploaded_data <- function(path, name) {
ext <- tolower(tools::file_ext(name))
if (ext == "sav") {
raw <- haven::read_sav(path)
labels <- vapply(raw, function(z) safe_label_text(attr(z, "label")), character(1))
datos <- as.data.frame(haven::zap_missing(haven::zap_labels(raw)), stringsAsFactors = FALSE)
return(list(data = datos, labels = labels, source = "SPSS", filename = name))
}
if (ext == "xlsx") {
datos <- as.data.frame(openxlsx::read.xlsx(path), stringsAsFactors = FALSE)
labels <- stats::setNames(rep("", ncol(datos)), names(datos))
return(list(data = datos, labels = labels, source = "Excel", filename = name))
}
if (ext == "xls") {
if (!requireNamespace("readxl", quietly = TRUE)) {
stop(
"Para leer archivos .xls instala el paquete readxl o guarda el archivo como .xlsx.\n",
'install.packages("readxl")',
call. = FALSE
)
}
datos <- as.data.frame(readxl::read_excel(path), stringsAsFactors = FALSE)
labels <- stats::setNames(rep("", ncol(datos)), names(datos))
return(list(data = datos, labels = labels, source = "Excel", filename = name))
}
if (ext == "csv") {
datos <- read.csv(path, stringsAsFactors = FALSE, check.names = FALSE)
labels <- stats::setNames(rep("", ncol(datos)), names(datos))
return(list(data = datos, labels = labels, source = "CSV", filename = name))
}
stop("Formato no soportado. Usa .sav, .xlsx, .xls o .csv")
}
var_label <- function(var, labels = NULL) {
lab <- safe_label_text(labels[[var]] %||% "")
if (nzchar(lab)) paste0(var, " - ", lab) else var
}
var_choices <- function(vars, labels = NULL) {
stats::setNames(vars, vapply(vars, var_label, character(1), labels = labels))
}
var_input_id <- function(prefix, var, datos) {
idx <- match(var, names(datos))
if (is.na(idx)) idx <- match(var, make.names(names(datos), unique = TRUE))
if (is.na(idx)) idx <- make.names(var)
paste0(prefix, "__", idx)
}
make_internal_map <- function(vars) {
stats::setNames(sprintf("V%03d", seq_along(vars)), vars)
}
replace_qca_labels <- function(x, label_map) {
if (is.null(x) || length(x) == 0 || length(label_map) == 0) return(x)
out <- as.character(x)
internal <- names(label_map)
internal <- internal[order(nchar(internal), decreasing = TRUE)]
for (nm in internal) {
lbl <- label_map[[nm]]
out <- gsub(paste0("\\b", nm, "\\b"), lbl, out, perl = TRUE)
}
out
}
relabel_df <- function(df, label_map) {
if (is.null(df) || !is.data.frame(df)) return(df)
names(df) <- replace_qca_labels(names(df), label_map)
for (cc in names(df)) {
if (is.character(df[[cc]]) || is.factor(df[[cc]])) {
df[[cc]] <- replace_qca_labels(as.character(df[[cc]]), label_map)
}
}
df
}
is_numericish <- function(x) {
if (is.numeric(x) || is.integer(x)) return(TRUE)
y <- suppressWarnings(as.numeric(as.character(x)))
mean(!is.na(y) | is.na(x)) > 0.95
}
numeric_values <- function(x) {
y <- safe_num(x)
y[!is.na(y)]
}
is_calibrated_01 <- function(x) {
y <- numeric_values(x)
length(y) > 0 && min(y) >= 0 && max(y) <= 1
}
is_binary_01 <- function(x) {
y <- numeric_values(x)
length(y) > 0 && all(unique(y) %in% c(0, 1))
}
detect_likert <- function(x) {
y <- numeric_values(x)
if (length(y) == 0) return(NA_integer_)
u <- sort(unique(y))
if (length(u) <= 10 && all(abs(u - round(u)) < 1e-8)) {
if (min(u) >= 1 && max(u) == 5) return(5L)
if (min(u) >= 1 && max(u) == 7) return(7L)
if (min(u) >= 1 && max(u) == 10) return(10L)
}
NA_integer_
}
skewness_soft <- function(x) {
y <- numeric_values(x)
if (length(y) < 3 || stats::sd(y) == 0) return(NA_real_)
mean(((y - mean(y)) / stats::sd(y))^3)
}
variable_stats <- function(x) {
y <- numeric_values(x)
if (length(y) == 0) {
return(data.frame(
Metrica = c("N", "Perdidos", "Valores únicos"),
Valor = c(length(x), sum(is.na(x)), length(unique(x))),
stringsAsFactors = FALSE
))
}
qs <- stats::quantile(y, probs = c(.05, .10, .20, .25, .50, .75, .80, .90, .95), na.rm = TRUE, names = TRUE)
data.frame(
Metrica = c("N válido", "Perdidos", "Min", "P5", "P10", "P20", "P25", "Mediana", "Media", "P75", "P80", "P90", "P95", "Max", "SD", "Asimetría", "Valores únicos"),
Valor = c(
length(y), sum(is.na(x)), min(y), qs[["5%"]], qs[["10%"]], qs[["20%"]], qs[["25%"]],
stats::median(y), mean(y), qs[["75%"]], qs[["80%"]], qs[["90%"]], qs[["95%"]],
max(y), stats::sd(y), skewness_soft(y), length(unique(y))
),
stringsAsFactors = FALSE
)
}
model_stats_table <- function(datos, vars, outcome = NULL) {
rows <- lapply(vars, function(v) {
y <- numeric_values(datos[[v]])
if (length(y) == 0) {
return(data.frame(
Variable = v,
Rol = if (identical(v, outcome)) "Outcome" else "Condición",
N_valido = sum(!is.na(datos[[v]])),
Missing = sum(is.na(datos[[v]])),
Min = NA_real_, P10 = NA_real_, P25 = NA_real_, Mediana = NA_real_, Media = NA_real_,
P75 = NA_real_, P90 = NA_real_, Max = NA_real_, SD = NA_real_,
Valores_unicos = length(unique(datos[[v]])),
Cortes_QCA_findTh = "No aplica: variable no numérica.",
stringsAsFactors = FALSE
))
}
qs <- stats::quantile(y, probs = c(.10, .25, .50, .75, .90), na.rm = TRUE)
data.frame(
Variable = v,
Rol = if (identical(v, outcome)) "Outcome" else "Condición",
N_valido = length(y),
Missing = sum(is.na(datos[[v]])),
Min = min(y),
P10 = qs[[1]],
P25 = qs[[2]],
Mediana = qs[[3]],
Media = mean(y),
P75 = qs[[4]],
P90 = qs[[5]],
Max = max(y),
SD = stats::sd(y),
Valores_unicos = length(unique(y)),
Cortes_QCA_findTh = findth_line(datos[[v]]),
stringsAsFactors = FALSE
)
})
out <- do.call(rbind, rows)
num_cols <- setdiff(names(out), c("Variable", "Rol", "Cortes_QCA_findTh"))
out[num_cols] <- lapply(out[num_cols], function(x) suppressWarnings(round(as.numeric(x), 3)))
names(out)[names(out) == "N_valido"] <- "N válido"
names(out)[names(out) == "Valores_unicos"] <- "Valores únicos"
names(out)[names(out) == "Cortes_QCA_findTh"] <- "Cortes QCA::findTh"
out
}
missing_profile <- function(datos) {
data.frame(
Variable = names(datos),
Tipo = vapply(datos, function(x) class(x)[1], character(1)),
N = nrow(datos),
Missing = vapply(datos, function(x) sum(is.na(x)), integer(1)),
Porcentaje_missing = round(vapply(datos, function(x) mean(is.na(x)), numeric(1)) * 100, 2),
Valores_unicos = vapply(datos, function(x) length(unique(x)), integer(1)),
Numericable = vapply(datos, is_numericish, logical(1)),
stringsAsFactors = FALSE
)
}
findth_line <- function(x) {
y <- numeric_values(x)
if (length(y) == 0) return("No aplica: variable no numérica.")
out <- try(paste(capture.output(QCA::findTh(y)), collapse = " | "), silent = TRUE)
if (inherits(out, "try-error")) "findTh no pudo calcular cortes para esta variable." else out
}
calibration_suggestions <- function(x) {
y <- numeric_values(x)
rows <- list()
add <- function(name, method, anchors, evidence, risk, report_text) {
rows[[length(rows) + 1]] <<- data.frame(
Propuesta = name,
Metodo = method,
Anchors = anchors,
Evidencia = evidence,
Riesgo = risk,
Texto_reporte = report_text,
stringsAsFactors = FALSE
)
}
if (length(y) == 0) {
add(
"Multivalor / categórica",
"crisp_multivalue",
"mapeo automático de categorías",
"La variable no parece numérica.",
"Debe justificarse que las categorías tienen significado sustantivo.",
"La condición fue tratada como multivalor/categórica a partir de sus categorías observadas."
)
return(do.call(rbind, rows))
}
lik <- detect_likert(y)
add(
"Literatura Likert 1-5",
"fuzzy_direct",
fmt_anchors(c(2, 3, 4)),
if (identical(lik, 5L)) "La variable parece una escala Likert 1-5." else "Opción fija si la escala sustantiva es Likert de 5 puntos.",
"Usa 2/3/4: exclusión plena, punto de cruce e inclusión plena.",
"Las anclas fuzzy se definieron según una escala Likert 1-5: exclusión plena = 2, punto de cruce = 3 e inclusión plena = 4."
)
add(
"Literatura Likert 1-7",
"fuzzy_direct",
fmt_anchors(c(2, 4, 6)),
if (identical(lik, 7L)) "La variable parece una escala Likert 1-7." else "Opción fija si la escala sustantiva es Likert de 7 puntos.",
"Usa 2/4/6: exclusión plena, punto de cruce e inclusión plena.",
"Las anclas fuzzy se definieron según una escala Likert 1-7: exclusión plena = 2, punto de cruce = 4 e inclusión plena = 6."
)
if (identical(lik, 10L)) {
add(
"Literatura Likert 1-10",
"fuzzy_direct",
fmt_anchors(c(8, 5, 2)),
"La variable parece una escala Likert 1-10.",
"La regla operativa usa 8/5/2: inclusión plena, punto de cruce y exclusión plena.",
"Las anclas fuzzy se definieron según una escala Likert 1-10: inclusión plena = 8, punto de cruce = 5 y exclusión plena = 2."
)
}
qs <- stats::quantile(y, probs = c(.05, .10, .20, .50, .80, .90, .95), na.rm = TRUE)
add(
"Empírica P10/P50/P90",
"fuzzy_direct",
fmt_anchors(c(qs[["10%"]], qs[["50%"]], qs[["90%"]])),
"Resume la distribución observada con un criterio habitual de tres anclas.",
"Puede ser demasiado mecánica si la teoría propone puntos sustantivos distintos.",
"Las anclas se contrastaron con la distribución empírica usando P10, mediana y P90."
)
add(
"Empírica P5/P50/P95",
"fuzzy_direct",
fmt_anchors(c(qs[["5%"]], qs[["50%"]], qs[["95%"]])),
"Usa puntos más exigentes para inclusión y exclusión plena.",
"En muestras pequeñas o sesgadas puede dejar pocos casos plenamente dentro o fuera.",
"Como prueba exigente, se evaluó una calibración basada en P95, mediana y P5."
)
add(
"Empírica P20/P50/P80",
"fuzzy_direct",
fmt_anchors(c(qs[["20%"]], qs[["50%"]], qs[["80%"]])),
"Puede funcionar mejor si la distribución está muy concentrada o sesgada.",
"Es menos estricta; debe justificarse con la distribución de los datos.",
"Se consideró una calibración alternativa P80, mediana y P20 por la forma de la distribución."
)
add(
"Empírica P25/Mediana/P75",
"fuzzy_direct",
fmt_anchors(c(stats::quantile(y, .25, na.rm = TRUE), stats::median(y, na.rm = TRUE), stats::quantile(y, .75, na.rm = TRUE))),
"Usa cuartiles y mediana como anclas empíricas centrales.",
"Puede ser útil como exploración, pero debe justificarse si la literatura exige puntos sustantivos.",
"Se evaluó una calibración basada en P25, mediana y P75 como criterio empírico de cuartiles."
)
do.call(rbind, rows)
}
calibration_suggestions_simple <- function(x) {
sug <- calibration_suggestions(x)
data.frame(
`Tipo de calibración` = sug$Propuesta,
`Anclas sugeridas (exclusión / cruce / inclusión)` = sug$Anchors,
`Comentario / sugerencia` = paste(sug$Evidencia, sug$Riesgo),
stringsAsFactors = FALSE,
check.names = FALSE
)
}
default_profile <- function(var, role_type) {
method <- switch(
role_type,
fuzzy_raw = "fuzzy_direct",
fuzzy_calibrated = "fuzzy_calibrated",
crisp_binary = "crisp_binary",
crisp_multivalue = "crisp_multivalue",
crisp_threshold = "crisp_threshold",
crisp_threshold_multi = "crisp_threshold_multi",
"fuzzy_direct"
)
list(
variable = var,
role_type = role_type,
method = method,
criterion = if (method %in% c("fuzzy_calibrated", "crisp_binary", "crisp_multivalue")) "Detectada por estructura de datos" else "Sin calibrar",
thresholds = c(NA_real_, NA_real_, NA_real_),
crisp_threshold = NA_real_,
direction = "increasing",
half_policy = "warn",
note = "",
approved = method %in% c("fuzzy_calibrated", "crisp_binary", "crisp_multivalue"),
mapping = NULL,
updated = as.character(Sys.time())
)
}
role_type_choices <- c(
"Valor original (requiere calibración)" = "fuzzy_raw",
"Fuzzy calibrado (0-1): no recalibrar" = "fuzzy_calibrated",
"Binario (0/1): usar valores observados" = "crisp_binary",
"Multivalor / categórico: usar categorías" = "crisp_multivalue"
)
is_continuous_candidate <- function(x) {
y <- numeric_values(x)
length(y) > 0 &&
length(unique(y)) > 10 &&
!is_calibrated_01(x) &&
is.na(detect_likert(x))
}
calibration_type_guidance <- function(x, role_type) {
if (identical(role_type, "fuzzy_calibrated")) {
return("Esta variable ya debe estar en valores fuzzy entre 0 y 1. La app no la recalibra: solo verifica el rango, aplica la política para 0.5 y registra la decisión.")
}
if (identical(role_type, "crisp_binary")) {
return("Esta variable se usa como conjunto binario. Si ya está en 0/1 se conserva; si tiene exactamente dos categorías, la app la recodifica internamente a 0/1 y registra el mapeo.")
}
if (identical(role_type, "crisp_multivalue")) {
return("Esta variable se usa como condición multivalor/categórica. La app usa sus estados como categorías y los recodifica internamente en enteros consecutivos para que QCA los lea correctamente.")
}
if (is_continuous_candidate(x)) {
return("Esta variable parece continua. En fsQCA no conviene incorporarla cruda: define una calibración sustantiva con literatura o criterio teórico, conviértela con un punto de corte binario, o vuelve al paso 2 y quítala del modelo.")
}
"Esta variable parte de valores originales. Debes convertirla en conjunto fuzzy mediante tres anchors o justificar una transformación binaria."
}
validate_direct_thresholds <- function(a) {
a <- as.numeric(a)
if (length(a) != 3 || any(is.na(a))) stop("Debes definir tres anclas: exclusión, punto de cruce e inclusión.")
if (!(all(diff(a) > 0) || all(diff(a) < 0))) {
stop("Las tres anclas deben estar en orden estricto. Para una relación creciente: exclusión < cruce < inclusión.")
}
a
}
map_multivalue <- function(x) {
vals <- x[!is.na(x)]
if (length(vals) == 0) stop("No hay valores válidos para mapear esta variable.")
if (is.numeric(vals) || is.integer(vals)) {
ux <- sort(unique(as.numeric(vals)))
codes <- seq_along(ux) - 1
mapped <- codes[match(as.numeric(x), ux)]
return(list(values = as.numeric(mapped), mapping = data.frame(Original = ux, Codigo = codes, stringsAsFactors = FALSE)))
}
ux <- sort(unique(as.character(vals)))
codes <- seq_along(ux) - 1
mapped <- codes[match(as.character(x), ux)]
list(values = as.numeric(mapped), mapping = data.frame(Original = ux, Codigo = codes, stringsAsFactors = FALSE))
}
map_binary <- function(x) {
vals <- x[!is.na(x)]
if (length(vals) == 0) stop("No hay valores válidos para mapear esta variable binaria.")
if (is.numeric(vals) || is.integer(vals)) {
ux <- sort(unique(as.numeric(vals)))
if (length(ux) == 2 && all(ux %in% c(0, 1))) {
return(list(values = as.numeric(x), mapping = NULL))
}
if (length(ux) != 2) stop("La variable binaria debe tener exactamente dos valores observados.")
codes <- c(0, 1)
mapped <- codes[match(as.numeric(x), ux)]
return(list(values = as.numeric(mapped), mapping = data.frame(Original = ux, Codigo = codes, stringsAsFactors = FALSE)))
}
ux <- sort(unique(as.character(vals)))
if (length(ux) != 2) stop("La variable binaria debe tener exactamente dos categorías observadas.")
codes <- c(0, 1)
mapped <- codes[match(as.character(x), ux)]
list(values = as.numeric(mapped), mapping = data.frame(Original = ux, Codigo = codes, stringsAsFactors = FALSE))
}
clean_try_error <- function(err) {
msg <- if (inherits(err, "try-error") && !is.null(attr(err, "condition"))) {
conditionMessage(attr(err, "condition"))
} else {
as.character(err)
}
msg <- gsub("^Error\\s*:\\s*", "", msg)
msg <- gsub("^Error in .*?:\\s*", "", msg)
trimws(msg)
}
explain_qca_error <- function(err, step = "QCA") {
msg <- clean_try_error(err)
if (grepl("Possibly uncalibrated multivalue conditions", msg, ignore.case = TRUE)) {
var <- sub(".*Please check:\\s*", "", msg, ignore.case = TRUE)
var <- trimws(gsub("[\\r\\n].*$", "", var))
return(paste0(
step, " se detuvo porque QCA detectó una condición multivalor sin preparar (", var, "). ",
"Vuelve al paso 3, revisa el tipo de esa variable y aplícala como fuzzy calibrada, binaria/dicotómica o multivalor/categórica. ",
"Si es una variable continua, no debe entrar cruda: calibra con anchors o usa un punto de corte binario justificado."
))
}
if (grepl("None of the values in OUT is explained", msg, ignore.case = TRUE)) {
return(paste0(
step, " se detuvo porque QCA no encontró configuraciones OUT=1 que puedan ser explicadas. ",
"No suele ser un error de sintaxis: normalmente indica que, con esos datos, calibraciones y cortes, la tabla de la verdad no deja filas suficientes para minimizar. ",
"Revisa OUT=1, consistencia, PRI, frecuencia mínima, número de condiciones y calibración del outcome."
))
}
paste(step, "se detuvo:", msg)
}
apply_half_policy <- function(values, policy) {
hit <- !is.na(values) & values == 0.5
if (!any(hit)) {
return(list(values = values, half_n = 0L, policy = policy))
}
if (identical(policy, "shift")) values[hit] <- 0.501
if (identical(policy, "exclude")) values[hit] <- NA_real_
list(values = values, half_n = sum(hit), policy = policy)
}
apply_profile_vector <- function(x, profile) {
method <- profile$method
policy <- profile$half_policy %||% "warn"
mapping <- NULL
if (identical(method, "fuzzy_direct")) {
thresholds <- validate_direct_thresholds(profile$thresholds)
values <- QCA::calibrate(
safe_num(x),
type = "fuzzy",
method = "direct",
thresholds = thresholds,
logistic = TRUE,
idm = 0.95,
ecdf = FALSE,
below = 1,
above = 1
)
half <- apply_half_policy(values, policy)
values <- half$values
} else if (identical(method, "fuzzy_calibrated")) {
values <- safe_num(x)
if (length(values[!is.na(values)]) == 0 || min(values, na.rm = TRUE) < 0 || max(values, na.rm = TRUE) > 1) {
stop("La variable no está en rango 0-1; no puede marcarse como fuzzy calibrada.")
}
half <- apply_half_policy(values, policy)
values <- half$values
} else if (identical(method, "crisp_binary")) {
bin <- map_binary(x)
values <- bin$values
mapping <- bin$mapping
half <- list(half_n = 0L, policy = "no aplica")
} else if (identical(method, "crisp_threshold")) {
th <- as.numeric(profile$crisp_threshold)
if (length(th) != 1 || is.na(th)) stop("Debes definir el punto de corte binario.")
values <- QCA::calibrate(safe_num(x), type = "crisp", thresholds = th)
half <- list(half_n = 0L, policy = "no aplica")
} else if (identical(method, "crisp_threshold_multi")) {
th <- sort(unique(as.numeric(profile$thresholds)))
th <- th[!is.na(th)]
if (length(th) < 2) stop("Para crisp multivalor debes definir al menos dos puntos de corte.")
values <- QCA::calibrate(safe_num(x), type = "crisp", thresholds = th)
half <- list(half_n = 0L, policy = "no aplica")
} else if (identical(method, "crisp_multivalue")) {
if (is_continuous_candidate(x)) {
stop("Esta variable parece continua, no multivalor/categórica. No la incorpores cruda: calibra con anchors fuzzy, define un punto de corte binario justificado o quítala del modelo.")
}
mv <- map_multivalue(x)
values <- mv$values
mapping <- mv$mapping
half <- list(half_n = 0L, policy = "no aplica")
} else {
stop("Método de calibración no reconocido.")
}
list(values = as.numeric(values), half_n = half$half_n, mapping = mapping)
}
normalize_modelo_qca <- function(modelo_txt) {
if (is.null(modelo_txt) || length(modelo_txt) == 0 || is.na(modelo_txt)) return(NA_character_)
n <- suppressWarnings(as.integer(sub("^M0*", "", as.character(modelo_txt))))
if (is.na(n)) return(as.character(modelo_txt))
paste0("M", n)
}
extract_formula_modelo_qca <- function(sol_txt, modelo = "M1") {
if (is.null(sol_txt) || !nzchar(sol_txt)) return(NA_character_)
modelo <- normalize_modelo_qca(modelo)
modelo_num <- suppressWarnings(as.integer(sub("^M", "", modelo)))
if (is.na(modelo_num)) return(NA_character_)
lines <- trimws(unlist(strsplit(sol_txt, "\n", fixed = TRUE)))
lines <- lines[nzchar(lines)]
idx <- grep(paste0("^M0*", modelo_num, "\\s*:"), lines)
if (length(idx) == 0) return(NA_character_)
i <- idx[1]
out <- sub("^M\\d+\\s*:\\s*", "", lines[i])
j <- i + 1
while (
j <= length(lines) &&
!grepl("^M\\d+\\s*:", lines[j]) &&
!grepl("^M\\d+\\s+[0-9.\\-]+\\s+[0-9.\\-]+\\s+[0-9.\\-]+$", lines[j]) &&
!grepl("^\\(M\\d+\\)", lines[j]) &&
!grepl("^[-]{5,}$", lines[j]) &&
!grepl("^inclS\\s+PRI\\s+covS", lines[j], ignore.case = TRUE) &&
!grepl("^From\\s", lines[j])
) {
out <- paste(out, lines[j])
j <- j + 1
}
out <- gsub("\\s+", " ", out)
out <- trimws(out)
sub("\\s*->.*$", "", out)
}
canonicalize_term_qca <- function(term_txt) {
if (is.null(term_txt) || length(term_txt) == 0 || is.na(term_txt)) return(NA_character_)
x <- gsub("\\s+", "", term_txt)
x <- gsub("[()]", "", x)
if (!nzchar(x)) return(NA_character_)
lits <- unlist(strsplit(x, "\\*", perl = TRUE))
lits <- lits[nzchar(lits)]
if (length(lits) == 0) return(NA_character_)
paste(sort(lits), collapse = "*")
}
split_terms_qca <- function(formula_txt) {
if (is.null(formula_txt) || length(formula_txt) == 0 || is.na(formula_txt) || !nzchar(formula_txt)) {
return(character(0))
}
x <- gsub("\\s+", "", formula_txt)
x <- gsub("[()]", "", x)
terms <- unlist(strsplit(x, "\\+", perl = TRUE))
terms <- terms[nzchar(terms)]
terms <- vapply(terms, canonicalize_term_qca, character(1))
unique(terms[!is.na(terms) & nzchar(terms)])
}
canonicalize_formula_qca <- function(formula_txt) {
terms <- split_terms_qca(formula_txt)
if (length(terms) == 0) return(NA_character_)
paste(sort(unique(terms)), collapse = " + ")
}
partial_match_qca <- function(formula_sol, formula_ref) {
ref_terms <- split_terms_qca(formula_ref)
sol_terms <- split_terms_qca(formula_sol)
if (length(ref_terms) == 0) {
return(list(n_terms_sol = length(sol_terms), n_terms_ref = 0L, n_terms_match = NA_integer_, match_pct = NA_real_, match_label = NA_character_))
}
n_match <- sum(ref_terms %in% sol_terms)
pct <- n_match / length(ref_terms)
label <- if (isTRUE(pct == 1)) "Exacta" else if (pct >= 0.75) "Parcial alta" else if (pct >= 0.50) "Parcial media" else "Baja"
list(n_terms_sol = length(sol_terms), n_terms_ref = length(ref_terms), n_terms_match = n_match, match_pct = pct, match_label = label)
}
solution_text <- function(sol) {
if (inherits(sol, "try-error")) return(as.character(sol))
paste(capture.output(print(sol)), collapse = "\n")
}
solution_text_display <- function(sol, label_map) {
replace_qca_labels(solution_text(sol), label_map)
}
solution_fit <- function(sol) {
if (inherits(sol, "try-error") || inherits(sol, "truthTable") || is.null(sol)) return(NULL)
df <- NULL
if (!is.null(sol$i.sol) && !is.null(sol$i.sol$IC) && !is.null(sol$i.sol$IC$incl.cov)) df <- sol$i.sol$IC$incl.cov
if (is.null(df) && !is.null(sol$IC) && !is.null(sol$IC$incl.cov)) df <- sol$IC$incl.cov
if (is.null(df)) return(NULL)
if (!is.null(colnames(df)) && "cases" %in% colnames(df)) df <- df[, colnames(df) != "cases", drop = FALSE]
data.frame(Termino = rownames(df), df, row.names = NULL, check.names = FALSE)
}
model_directions <- function(scope) {
if (identical(scope, "both")) return(c("presence", "absence"))
if (identical(scope, "absence")) return("absence")
"presence"
}
direction_label <- function(x) {
if (identical(x, "absence")) "Ausencia del outcome" else "Presencia del outcome"
}
model_scope_label <- function(scope) {
switch(scope, presence = "presencia", absence = "ausencia", both = "presencia y ausencia", scope %||% "sin definir")
}
parse_numeric_grid <- function(txt, default = numeric(0), integer = FALSE) {
if (is.null(txt) || !nzchar(trimws(txt))) return(default)
parts <- unlist(strsplit(gsub(";", ",", txt), ",", fixed = TRUE))
vals <- suppressWarnings(as.numeric(trimws(parts[nzchar(trimws(parts))])))
vals <- vals[!is.na(vals)]
if (integer) vals <- unique(pmax(1, round(vals))) else vals <- unique(pmax(0, pmin(1, vals)))
sort(vals)
}
truth_cutoffs_for <- function(input, direction) {
if (identical(direction, "absence")) {
list(
incl = suppressWarnings(as.numeric(input$incl_cut_absence %||% input$incl_cut_presence %||% .80)),
pri = suppressWarnings(as.numeric(input$pri_cut_absence %||% input$pri_cut_presence %||% .75)),
n = suppressWarnings(as.numeric(input$n_cut_absence %||% input$n_cut_presence %||% 1))
)
} else {
list(
incl = suppressWarnings(as.numeric(input$incl_cut_presence %||% .80)),
pri = suppressWarnings(as.numeric(input$pri_cut_presence %||% .75)),
n = suppressWarnings(as.numeric(input$n_cut_presence %||% 1))
)
}
}
build_outcome_spec <- function(model, calibrated, direction) {
out_var <- model$outcome
out_int <- unname(model$internal_map[[out_var]])
out_profile <- calibrated$profiles[[out_var]]
target <- model$outcome_target
spec <- out_int
if (identical(out_profile$method, "crisp_multivalue") && !is.null(target) && nzchar(target)) {
spec <- paste0(out_int, "{", target, "}")
}
if (identical(direction, "absence")) paste0("~", spec) else spec
}
build_necessity_data <- function(model, calibrated, direction) {
out_var <- model$outcome
out_int <- unname(model$internal_map[[out_var]])
out_profile <- calibrated$profiles[[out_var]]
df <- calibrated$data
out_col <- if (identical(direction, "absence")) "OUTCOME_MODELADO_AUSENCIA" else "OUTCOME_MODELADO_PRESENCIA"
if (identical(out_profile$method, "crisp_multivalue") && nzchar(model$outcome_target %||% "")) {
target_vals <- suppressWarnings(as.numeric(strsplit(model$outcome_target, ",", fixed = TRUE)[[1]]))
membership <- as.numeric(df[[out_int]] %in% target_vals)
df[[out_col]] <- if (identical(direction, "absence")) 1 - membership else membership
} else {
df[[out_col]] <- if (identical(direction, "absence")) 1 - df[[out_int]] else df[[out_int]]
}
list(data = df, outcome = out_col)
}
dir_exp_vector <- function(model) {
out <- vapply(model$conditions, function(v) {
val <- model$directions[[v]] %||% "none"
if (identical(val, "present")) return("1")
if (identical(val, "absent")) return("0")
"-"
}, FUN.VALUE = character(1))
unname(out)
}
build_calibrated_project <- function(active_data, model, profiles, half_policy_global = "warn") {
vars <- c(model$outcome, model$conditions)
out <- data.frame(row.names = seq_len(nrow(active_data)))
applied <- list()
half_rows <- list()
mapping_rows <- list()
for (v in vars) {
prof <- profiles[[v]]
if (is.null(prof) || !isTRUE(prof$approved)) {
stop(paste("La variable", v, "no está calibrada/aplicada."))
}
if ((prof$method %||% "") %in% c("fuzzy_direct", "fuzzy_calibrated")) {
prof$half_policy <- half_policy_global %||% "warn"
} else {
prof$half_policy <- "no aplica"
}
applied_vec <- apply_profile_vector(active_data[[v]], prof)
internal <- unname(model$internal_map[[v]])
out[[internal]] <- applied_vec$values
prof$mapping <- applied_vec$mapping
applied[[v]] <- prof
half_rows[[v]] <- data.frame(Variable = v, Casos_05 = applied_vec$half_n, `Política` = prof$half_policy %||% "warn", stringsAsFactors = FALSE, check.names = FALSE)
if (!is.null(applied_vec$mapping)) {
tmp <- applied_vec$mapping
tmp$Variable <- v
mapping_rows[[v]] <- tmp[, c("Variable", setdiff(names(tmp), "Variable")), drop = FALSE]
}
}
complete <- stats::complete.cases(out)
label_map <- stats::setNames(names(model$internal_map), unname(model$internal_map))
list(
data = out[complete, , drop = FALSE],
dropped = sum(!complete),
internal_map = model$internal_map,
label_map = label_map,
profiles = applied,
half_table = do.call(rbind, half_rows),
mappings = if (length(mapping_rows)) do.call(rbind, mapping_rows) else data.frame()
)
}
truth_counts <- function(tt) {
tt_tab <- if (!is.null(tt$tt)) tt$tt else tt
outs <- table(tt_tab$OUT, useNA = "ifany")
out <- data.frame(OUT = names(outs), Frecuencia = as.integer(outs), stringsAsFactors = FALSE)
out$Descripcion <- ifelse(
out$OUT == "1", "Configuraciones que explican el outcome modelado",
ifelse(out$OUT == "0", "Configuraciones que no explican el outcome modelado",
ifelse(out$OUT == "?", "Configuraciones ambiguas o sin clasificación clara",
ifelse(out$OUT == "C", "Configuraciones contradictorias", "Valor no previsto")
)
)
)
out
}
truth_has_object <- function(truth) {
length(truth) > 0 && any(vapply(truth, function(x) !is.null(x$object), logical(1)))
}
necessity_condition_set <- function(model, profiles) {
keep <- model$conditions[vapply(model$conditions, function(v) {
method <- profiles[[v]]$method %||% ""
method %in% c("fuzzy_direct", "fuzzy_calibrated")
}, logical(1))]
internal <- unname(model$internal_map[keep])
list(
raw = keep,
internal = internal,
all_internal = internal,
excluded = setdiff(model$conditions, keep)
)
}
make_public_solution_table <- function(sol, sol_txt, prefix, label_map, curated = NULL) {
formula <- extract_formula_modelo_qca(sol_txt, "M1")
terms <- split_terms_qca(formula)
fit <- solution_fit(sol)
if (length(terms) == 0) {
return(data.frame(
Configuration = character(0),
Expression = character(0),
Raw_coverage = numeric(0),
Unique_coverage = numeric(0),
Consistency = numeric(0),
Included = logical(0),
Reason = character(0)
))
}
fit_terms <- if (!is.null(fit)) fit[!grepl("^M\\d+$", fit$Termino), , drop = FALSE] else data.frame()
raw_cov <- unique_cov <- cons <- rep(NA_real_, length(terms))
if (nrow(fit_terms) > 0) {
n <- min(nrow(fit_terms), length(terms))
if ("covS" %in% names(fit_terms)) raw_cov[seq_len(n)] <- suppressWarnings(as.numeric(fit_terms$covS[seq_len(n)]))
if ("covU" %in% names(fit_terms)) unique_cov[seq_len(n)] <- suppressWarnings(as.numeric(fit_terms$covU[seq_len(n)]))
if ("inclS" %in% names(fit_terms)) cons[seq_len(n)] <- suppressWarnings(as.numeric(fit_terms$inclS[seq_len(n)]))
}
included <- rep(TRUE, length(terms))
reason <- rep("", length(terms))
if (!is.null(curated) && length(curated$included_terms) > 0) {
included <- terms %in% curated$included_terms
reason[!included] <- curated$reason %||% "Excluida por decision del investigador"
}
data.frame(
Configuration = paste0(prefix, seq_along(terms)),
Expression = replace_qca_labels(terms, label_map),
Raw_coverage = raw_cov,
Unique_coverage = unique_cov,
Consistency = cons,
Included = included,
Reason = reason,
stringsAsFactors = FALSE
)
}
overall_solution_fit <- function(sol) {
fit <- solution_fit(sol)
if (is.null(fit) || nrow(fit) == 0) return(data.frame(Metrica = character(0), Valor = numeric(0)))
rows <- fit[grepl("^M\\d+$", fit$Termino), , drop = FALSE]
if (nrow(rows) == 0) rows <- fit[nrow(fit), , drop = FALSE]
data.frame(
Metrica = c("Overall consistency", "Overall PRI", "Overall coverage"),
Valor = c(
if ("inclS" %in% names(rows)) suppressWarnings(as.numeric(rows$inclS[1])) else NA_real_,
if ("PRI" %in% names(rows)) suppressWarnings(as.numeric(rows$PRI[1])) else NA_real_,
if ("covS" %in% names(rows)) suppressWarnings(as.numeric(rows$covS[1])) else NA_real_
),
stringsAsFactors = FALSE
)
}
core_peripheral_table <- function(sol_pars_txt, sol_inter_txt, label_map, prefix) {
pars <- split_terms_qca(extract_formula_modelo_qca(sol_pars_txt, "M1"))
inter <- split_terms_qca(extract_formula_modelo_qca(sol_inter_txt, "M1"))
if (length(inter) == 0) {
return(data.frame(Configuration = character(0), Termino = character(0), Clasificacion = character(0)))
}
data.frame(
Configuration = paste0(prefix, seq_along(inter)),
Termino = replace_qca_labels(inter, label_map),
Clasificacion = ifelse(inter %in% pars, "Core", "Periferica"),
stringsAsFactors = FALSE
)
}
plot_solution_flowers <- function(sol_inter_txt, sol_pars_txt, conditions, label_map, title = "") {
formula <- extract_formula_modelo_qca(sol_inter_txt, "M1")
terms <- split_terms_qca(formula)
pars <- split_terms_qca(extract_formula_modelo_qca(sol_pars_txt, "M1"))
if (length(terms) == 0) {
plot.new()
text(.5, .5, "Sin configuraciones para graficar")
return(invisible(NULL))
}
n <- length(terms)
rows <- ceiling(sqrt(n))
cols <- ceiling(n / rows)
old <- par(mfrow = c(rows, cols), mar = c(1, 1, 3, 1))
on.exit(par(old), add = TRUE)
for (i in seq_along(terms)) {
term <- terms[[i]]
lits <- unlist(strsplit(gsub("[()]", "", term), "\\*", perl = TRUE))
lits <- lits[nzchar(lits)]
is_core <- term %in% pars
plot.new()
plot.window(xlim = c(-1.45, 1.45), ylim = c(-1.45, 1.45), asp = 1)
title(main = paste0(title, i), cex.main = .95)
symbols(0, 0, circles = .24, add = TRUE, inches = FALSE, bg = "#22313f", fg = "#22313f")
text(0, 0, paste0(title, i), col = "white", font = 2, cex = .9)
angles <- seq(0, 2 * pi, length.out = length(conditions) + 1)[-1]
for (j in seq_along(conditions)) {
cond <- conditions[[j]]
lab <- replace_qca_labels(cond, label_map)
present <- cond %in% lits
absent <- paste0("~", cond) %in% lits
if (!present && !absent) next
x <- cos(angles[j])
y <- sin(angles[j])
fill <- if (present && is_core) "#c8c9c7" else if (present) "#ffffff" else "#ffffff"
border <- if (absent) "#8a2635" else "#22313f"
lty <- if (absent) 2 else 1
symbols(x * .72, y * .72, circles = .18, add = TRUE, inches = FALSE, bg = fill, fg = border, lwd = 2, lty = lty)
text(x * 1.08, y * 1.08, lab, cex = .68)
}
}
}
diagnose_truth_table <- function(tt_counts_df, n_conditions, n_cases) {
if (is.null(tt_counts_df) || nrow(tt_counts_df) == 0) return("No hay tablas de la verdad disponibles.")
getn <- function(code) {
z <- tt_counts_df$Frecuencia[tt_counts_df$OUT == code]
if (length(z) == 0) 0 else z[1]
}
out1 <- getn("1")
outq <- getn("?")
outc <- getn("C")
configs <- 2^n_conditions
notes <- character(0)
if (out1 == 0) notes <- c(notes, "No hay configuraciones OUT=1; con estos cortes no habrá solución suficiente para minimizar.")
if (outq > out1) notes <- c(notes, "Hay más filas ambiguas que filas positivas; revisa consistencia, PRI, frecuencia mínima o calibración.")
if (outc > 0) notes <- c(notes, "Hay contradicciones explícitas; conviene inspeccionar casos y criterios de inclusión.")
if (configs > n_cases * 2) notes <- c(notes, "La diversidad limitada puede ser alta para el N disponible.")
if (length(notes) == 0) notes <- "Las tablas de la verdad parecen utilizables como punto de partida."
paste(notes, collapse = " ")
}
truth_count_value <- function(counts, code) {
if (is.null(counts) || !is.data.frame(counts) || !"OUT" %in% names(counts) || !"Frecuencia" %in% names(counts)) return(0L)
val <- counts$Frecuencia[as.character(counts$OUT) == code]
if (length(val) == 0 || is.na(val[1])) 0L else as.integer(val[1])
}
truth_has_out1 <- function(truth_item) {
truth_count_value(truth_item$counts, "1") > 0
}
truth_has_any_out1 <- function(truth) {
length(truth) > 0 && any(vapply(truth, truth_has_out1, logical(1)))
}
manual_qca_cache <- local({
cache <- NULL
function() {
if (!is.null(cache)) return(cache)
files <- c(
file.path("pdf_extracted_text", "QCA.txt"),
file.path("pdf_extracted_text", "fsqca con R Steps.txt"),
file.path("pdf_extracted_text", "Seminario fuzzy Alicante 2023 (1).txt"),
"FSQCA_METHOD_RULES.md"
)
rows <- list()
for (f in files[file.exists(files)]) {
txt <- readLines(f, warn = FALSE, encoding = "UTF-8")
txt <- trimws(txt)
txt <- txt[nzchar(txt)]
if (length(txt) == 0) next
rows[[length(rows) + 1]] <- data.frame(source = basename(f), line = txt, stringsAsFactors = FALSE)
}
cache <<- if (length(rows)) do.call(rbind, rows) else data.frame(source = character(0), line = character(0))
cache
}
})
manual_qca_answer <- function(txt) {
docs <- manual_qca_cache()
if (nrow(docs) == 0) return(NA_character_)
terms <- unique(unlist(strsplit(tolower(txt), "[^[:alnum:]áéíóúñ]+", perl = TRUE)))
terms <- terms[nchar(terms) >= 4]
terms <- setdiff(terms, c("sobre", "para", "como", "porque", "quiero", "puedes", "tanguito"))
if (length(terms) == 0) return(NA_character_)
low_lines <- tolower(docs$line)
scores <- vapply(low_lines, function(line) sum(vapply(terms, grepl, logical(1), x = line, fixed = TRUE)), numeric(1))
idx <- which(scores > 0)
if (length(idx) == 0) return(NA_character_)
idx <- idx[order(scores[idx], decreasing = TRUE)]
idx <- idx[seq_len(min(3, length(idx)))]
snippets <- paste0("- ", docs$line[idx], " (", docs$source[idx], ")")
paste("Según el material local del curso/manual:", paste(snippets, collapse = " "))
}
tanguito_local_answer <- function(txt, rv, input) {
low <- tolower(txt)
if (grepl("anchor|calibr|corte|umbr", low)) {
if (!is.null(input$calib_var) && nzchar(input$calib_var) && !is.null(rv$active_data)) {
sug <- calibration_suggestions(rv$active_data[[input$calib_var]])
best <- sug[1, , drop = FALSE]
return(paste0(
"Mira, para ", input$calib_var, " yo empezaria mirando ", best$Propuesta,
". Evidencia: ", best$Evidencia,
" Ojo: ", best$Riesgo,
" Si te cierra teóricamente, puedes cargar esa propuesta y aplicarla."
))
}
return("Para hablar de anclas necesito que estés en calibración y elijas una variable. Primero va el criterio teórico; después usamos la distribución como evidencia.")
}
if (grepl("findth|find th|qca::find", low)) {
return("QCA::findTh() es una función exploratoria del paquete QCA. Te da un umbral sugerido para mirar la distribución; sirve como evidencia descriptiva, no como calibración automática.")
}
if (grepl("solucion|soluciones|no hay|fall", low)) {
if (length(rv$truth) == 0) return("Si no hay soluciones, primero hay que revisar las tablas de la verdad: configuraciones OUT=1, OUT=?, PRI, frecuencia mínima y calibración del outcome.")
notes <- vapply(rv$truth, function(x) x$diagnosis %||% "", character(1))
notes <- notes[nzchar(notes)]
if (length(notes) == 0) return("Las tablas de la verdad existen, pero no tengo diagnósticos cargados. Revisa si hay configuraciones OUT=1 antes de minimizar.")
return(paste(notes, collapse = " "))
}
if (grepl("robust|sensib", low)) {
if (is.null(rv$robustness)) return("La robustez todavía no se ejecutó. Cuando la corramos, comparo cada variante contra la solución intermedia de referencia y marco qué configuraciones se sostienen.")
stable <- mean(rv$robustness$Estabilidad == "Estable", na.rm = TRUE)
return(paste0("La robustez muestra ", round(stable * 100, 1), "% de escenarios estables. Yo revisaría con lupa las filas no estables antes de llevar la tabla al paper."))
}
if (grepl("paper|reporte|tabla|suplement|word|excel", low)) {
return("Para el paper o suplemento: solución intermedia curada, cobertura bruta, cobertura única y consistencia. En reporte dejo una tabla de soluciones y una tabla de robustez.")
}
if (grepl("0\\.5|medio|ambig", low)) {
return("Los 0.5 son casos de máxima ambigüedad. No conviene tocarlos en silencio: conservar y advertir, mover a 0.501, o excluirlos son decisiones distintas y deben quedar reportadas.")
}
if (grepl("out\\b|out=|\\?", low)) {
return("En las tablas de la verdad, OUT=1 indica configuraciones suficientes para el outcome modelado; OUT=0 indica configuraciones que no entran; OUT=? indica ambigüedad, falta de evidencia o configuración no clasificada con los cortes actuales.")
}
if (grepl("condicion|condiciones|cuantas|6", low)) {
return("Como regla práctica, evita cargar demasiadas condiciones. Más de 6 condiciones aumenta mucho las configuraciones posibles y puede generar diversidad limitada, salvo que la teoría lo justifique muy bien.")
}
manual_ans <- manual_qca_answer(txt)
if (!is.na(manual_ans) && nzchar(manual_ans)) return(manual_ans)
paste0(
"Puedo ayudarte con calibración, QCA::findTh, valores 0.5, tablas de la verdad, presencia/ausencia, soluciones, robustez o tablas para el paper. Paso actual: ",
if (!is.null(rv$current_step)) steps$title[steps$id == rv$current_step] else "sin paso",
"."
)
}
write_sheet <- function(wb, name, df) {
if (is.null(df)) df <- data.frame()
if (!is.data.frame(df)) df <- as.data.frame(df)
addWorksheet(wb, name)
writeData(wb, name, df)
if (ncol(df) > 0) {
setColWidths(wb, name, cols = 1:ncol(df), widths = "auto")
}
}
write_results_workbook <- function(file, rv) {
wb <- createWorkbook()
style_head <- createStyle(textDecoration = "bold", fgFill = "#eef2f3")
add <- function(name, df) {
write_sheet(wb, name, df)
if (length(wb$worksheets) > 0 && ncol(df %||% data.frame()) > 0) {
addStyle(wb, name, style_head, rows = 1, cols = 1:ncol(df), gridExpand = TRUE, stack = TRUE)
}
}
add_text <- function(name, txt) {
if (is.null(txt) || !nzchar(txt)) return(NULL)
write_sheet(wb, name, data.frame(Line = unlist(strsplit(txt, "\n", fixed = TRUE)), stringsAsFactors = FALSE))
}
cfg_df <- data.frame(
Parametro = c(
"archivo", "fuente", "segmento", "outcome_raw", "conds_raw", "modelo_estimado",
"n_casos", "n_condiciones", "nota_01", "nota_02", "nota_03"
),
Valor = c(
rv$file_meta$filename %||% NA,
rv$file_meta$source %||% NA,
rv$segment_label %||% "Modelo completo",
rv$model$outcome %||% NA,
if (!is.null(rv$model)) paste(rv$model$conditions, collapse = ", ") else NA,
rv$model$scope %||% NA,
if (!is.null(rv$active_data)) nrow(rv$active_data) else NA,
if (!is.null(rv$model)) length(rv$model$conditions) else NA,
"Los valores 0.5 se tratan según la política global definida por el investigador.",
"Las tablas de la verdad clasifican configuraciones usando consistencia, PRI y frecuencia mínima.",
"La estabilidad en sensibilidad compara contra la solución intermedia original."
),
stringsAsFactors = FALSE
)
add("01_Config", cfg_df)
vars_model <- if (!is.null(rv$model)) c(rv$model$outcome, rv$model$conditions) else character(0)
if (length(vars_model) > 0 && !is.null(rv$active_data)) {
add("02_Calibracion_Summary", model_stats_table(rv$active_data, vars_model, rv$model$outcome))
} else if (!is.null(rv$missing)) {
add("02_Calibracion_Summary", rv$missing)
}
if (length(rv$profiles) > 0) {
prof_df <- do.call(rbind, lapply(rv$profiles, function(p) {
data.frame(
Variable = p$variable,
Anchor_bajo = if (identical(p$method, "fuzzy_direct")) p$thresholds[1] else NA_real_,
Crossover = if (identical(p$method, "fuzzy_direct")) p$thresholds[2] else NA_real_,
Anchor_alto = if (identical(p$method, "fuzzy_direct")) p$thresholds[3] else NA_real_,
Metodo = calibration_method_label(p$method),
Criterio = p$criterion %||% "",
Estado = if (isTRUE(p$approved)) "Calibrada/aplicada" else "Sin calibrar",
Nota = p$note %||% "",
stringsAsFactors = FALSE,
check.names = FALSE
)
}))
add("03_Explorar_Cortes", prof_df)
add("15_Anchors_Usados_Robustez", prof_df)
} else {
add("03_Explorar_Cortes", data.frame())
}
nec_list <- lapply(names(rv$necessity), function(dir) {
x <- rv$necessity[[dir]]
if (is.null(x)) return(NULL)
x$Modelo <- direction_label(dir)
x
})
nec_list <- nec_list[!vapply(nec_list, is.null, logical(1))]
add("04_Necesidad_Flags", if (length(nec_list)) do.call(rbind, nec_list) else data.frame())
tt_list <- lapply(names(rv$truth), function(dir) {
x <- rv$truth[[dir]]$table
if (is.null(x)) return(NULL)
x$Modelo <- direction_label(dir)
x
})
tt_list <- tt_list[!vapply(tt_list, is.null, logical(1))]
add("05_TruthTable", if (length(tt_list)) do.call(rbind, tt_list) else data.frame())
out_list <- lapply(names(rv$truth), function(dir) {
x <- rv$truth[[dir]]$counts
if (is.null(x)) return(NULL)
x$Modelo <- direction_label(dir)
x
})
out_list <- out_list[!vapply(out_list, is.null, logical(1))]
add("06_TT_OUT", if (length(out_list)) do.call(rbind, out_list) else data.frame())
add("08_TT_Untenable_Resumen", data.frame(
Tipo = c("CSA", "SSR"),
Cantidad = NA_integer_,
Descripcion = c(
"Pendiente de auditoría automática con findRows(type = 2).",
"Pendiente de auditoría automática con findRows(type = 3)."
),
stringsAsFactors = FALSE
))
complex_txt <- paste(vapply(rv$solutions, function(x) x$complex_display_txt %||% "", character(1)), collapse = "\n\n")
pars_txt <- paste(vapply(rv$solutions, function(x) x$pars_display_txt %||% "", character(1)), collapse = "\n\n")
inter_txt <- paste(vapply(rv$solutions, function(x) x$inter_display_txt %||% "", character(1)), collapse = "\n\n")
add_text("09_Sol_Complex", complex_txt)
add_text("10_Sol_Parsimoniosa", pars_txt)
add_text("11_Sol_Intermedia", inter_txt)
core_list <- lapply(names(rv$solutions), function(dir) {
x <- rv$solutions[[dir]]$core
if (is.null(x)) return(NULL)
x$Modelo <- direction_label(dir)
x
})
core_list <- core_list[!vapply(core_list, is.null, logical(1))]
add("12_Core_Condition", if (length(core_list)) do.call(rbind, core_list) else data.frame())
add("13_Soluciones_Sens", rv$robustness %||% data.frame())
add("14_Robustez_Anchors", data.frame(
Nota = "Robustez de anchors pendiente de implementación específica. Esta hoja queda reservada para recalibraciones alternativas.",
stringsAsFactors = FALSE
))
paper_table <- report_solution_matrix_df(rv)
if (is.data.frame(paper_table) && nrow(paper_table) > 0) add("16_Reporte_Visual", paper_table)
saveWorkbook(wb, file, overwrite = TRUE)
}
make_report_text <- function(rv) {
lines <- c(
"Módulo fsQCA - Material suplementario",
"Soluciones QCA del modelo",
""
)
for (dir in c("presence", "absence")) {
sol <- rv$solutions[[dir]]
if (is.null(sol)) next
lines <- c(lines, direction_label(dir), "")
if (!is.null(sol$complex_display_txt) && nzchar(sol$complex_display_txt)) {
lines <- c(lines, "Solución compleja", sol$complex_display_txt, "")
}
if (!is.null(sol$inter_display_txt) && nzchar(sol$inter_display_txt)) {
lines <- c(lines, "Solución intermedia", sol$inter_display_txt, "")
}
if (!is.null(sol$pars_display_txt) && nzchar(sol$pars_display_txt)) {
lines <- c(lines, "Solución parsimoniosa", sol$pars_display_txt, "")
}
}
paste(lines, collapse = "\n")
}
report_solution_df <- function(rv) {
rows <- list()
for (dir in c("presence", "absence")) {
sol <- rv$solutions[[dir]]
if (is.null(sol)) next
pieces <- list(
"Compleja" = sol$public_complex,
"Parsimoniosa" = sol$public_pars,
"Intermedia" = sol$public_inter
)
for (nm in names(pieces)) {
tab <- pieces[[nm]]
if (is.null(tab) || nrow(tab) == 0) next
tab <- tab[, intersect(c("Configuration", "Expression", "Raw_coverage", "Unique_coverage", "Consistency"), names(tab)), drop = FALSE]
tab$Modelo <- direction_label(dir)
tab$`Tipo de solución` <- nm
rows[[length(rows) + 1]] <- tab[, c("Modelo", "Tipo de solución", names(tab)[!names(tab) %in% c("Modelo", "Tipo de solución")]), drop = FALSE]
}
}
if (!length(rows)) return(data.frame())
out <- do.call(rbind, rows)
names(out) <- c("Modelo", "Tipo de solución", "Configuración", "Expresión", "Cobertura bruta", "Cobertura única", "Consistencia")
out
}
paper_num <- function(x, digits = 2) {
if (length(x) == 0 || is.na(x)) return("")
z <- format(round(as.numeric(x), digits), nsmall = digits, trim = TRUE)
sub("^(-?)0\\.", "\\1.", z)
}
term_literals_qca <- function(term_txt) {
if (is.null(term_txt) || length(term_txt) == 0 || is.na(term_txt)) return(character(0))
x <- gsub("\\s+", "", term_txt)
x <- gsub("[()]", "", x)
lits <- unlist(strsplit(x, "\\*", perl = TRUE))
lits[nzchar(lits)]
}
condition_symbol_qca <- function(term_txt, condition) {
lits <- term_literals_qca(term_txt)
if (condition %in% lits) return("●")
if (paste0("~", condition) %in% lits) return("⊗")
""
}
condition_symbol_tag_qca <- function(sym) {
if (identical(sym, "●")) return(tags$span(HTML("●")))
if (identical(sym, "⊗")) return(tags$span(HTML("⊗")))
""
}
solution_report_items <- function(sol) {
if (is.null(sol) || is.null(sol$public_inter)) return(data.frame())
tab <- sol$public_inter
if (nrow(tab) == 0) return(data.frame())
terms <- split_terms_qca(extract_formula_modelo_qca(sol$inter_txt %||% "", "M1"))
n <- min(length(terms), nrow(tab))
if (n == 0) return(data.frame())
terms <- terms[seq_len(n)]
tab <- tab[seq_len(n), , drop = FALSE]
keep <- if ("Included" %in% names(tab)) tab$Included %in% TRUE else rep(TRUE, n)
if (!any(keep)) return(data.frame())
data.frame(
Configuracion = tab$Configuration[keep],
Termino = terms[keep],
Cobertura_bruta = suppressWarnings(as.numeric(tab$Raw_coverage[keep])),
Cobertura_unica = suppressWarnings(as.numeric(tab$Unique_coverage[keep])),
Consistencia = suppressWarnings(as.numeric(tab$Consistency[keep])),
stringsAsFactors = FALSE
)
}
overall_report_metric <- function(sol, metric) {
tab <- sol$overall_inter %||% data.frame()
if (!is.data.frame(tab) || nrow(tab) == 0 || !"Metrica" %in% names(tab) || !"Valor" %in% names(tab)) return(NA_real_)
val <- tab$Valor[tab$Metrica == metric]
if (length(val) == 0) NA_real_ else suppressWarnings(as.numeric(val[1]))
}
report_solution_blocks <- function(rv) {
if (is.null(rv$model) || length(rv$solutions) == 0) return(list())
dirs <- c("presence", "absence")
blocks <- list()
for (dir in dirs) {
sol <- rv$solutions[[dir]]
if (is.null(sol)) next
items <- solution_report_items(sol)
if (!is.data.frame(items) || nrow(items) == 0) next
blocks[[length(blocks) + 1]] <- list(
dir = dir,
label = if (identical(dir, "presence")) "Presence" else "Absence",
items = items,
overall_coverage = overall_report_metric(sol, "Overall coverage"),
overall_consistency = overall_report_metric(sol, "Overall consistency")
)
}
blocks
}
report_condition_labels <- function(rv) {
if (is.null(rv$model)) return(character(0))
stats::setNames(
vapply(rv$model$conditions, var_label, character(1), labels = rv$labels),
unname(rv$model$internal_map[rv$model$conditions])
)
}
report_system_label <- function(rv) {
rv$segment_label %||% "Modelo actual"
}
report_solution_matrix_df <- function(rv) {
blocks <- report_solution_blocks(rv)
if (length(blocks) == 0) return(data.frame())
configs <- unlist(lapply(blocks, function(b) b$items$Configuracion), use.names = FALSE)
conds <- report_condition_labels(rv)
rows <- list()
for (cond in names(conds)) {
vals <- unlist(lapply(blocks, function(b) vapply(b$items$Termino, condition_symbol_qca, character(1), condition = cond)), use.names = FALSE)
rows[[length(rows) + 1]] <- c(Condition = unname(conds[[cond]]), stats::setNames(vals, configs))
}
metric_row <- function(label, field) {
vals <- unlist(lapply(blocks, function(b) vapply(b$items[[field]], paper_num, character(1), digits = 2)), use.names = FALSE)
c(Condition = label, stats::setNames(vals, configs))
}
rows[[length(rows) + 1]] <- metric_row("Raw Coverage", "Cobertura_bruta")
rows[[length(rows) + 1]] <- metric_row("Unique Coverage", "Cobertura_unica")
rows[[length(rows) + 1]] <- metric_row("Consistency", "Consistencia")
overall_row <- function(label, field) {
vals <- character(0)
for (b in blocks) {
val <- paper_num(b[[field]], 2)
vals <- c(vals, val, rep("", max(0, nrow(b$items) - 1)))
}
c(Condition = label, stats::setNames(vals, configs))
}
rows[[length(rows) + 1]] <- overall_row("Overall coverage", "overall_coverage")
rows[[length(rows) + 1]] <- overall_row("Overall consistency", "overall_consistency")
out <- as.data.frame(do.call(rbind, rows), stringsAsFactors = FALSE, check.names = FALSE)
rownames(out) <- NULL
out
}
report_solution_matrix_ui <- function(rv) {
blocks <- report_solution_blocks(rv)
if (length(blocks) == 0) return(div(class = "locked-box", "Ejecuta soluciones para ver la tabla visual de soluciones fsQCA."))
conds <- report_condition_labels(rv)
total_cols <- sum(vapply(blocks, function(b) nrow(b$items), integer(1)))
outcome <- if (!is.null(rv$model)) var_label(rv$model$outcome, rv$labels) else "Outcome"
group_cells <- unlist(lapply(blocks, function(b) list(tags$th(class = "paper-group", colspan = nrow(b$items), b$label))), recursive = FALSE)
config_cells <- unlist(lapply(blocks, function(b) lapply(b$items$Configuracion, function(x) tags$th(class = "paper-config", x))), recursive = FALSE)
condition_rows <- lapply(names(conds), function(cond) {
cells <- unlist(lapply(blocks, function(b) {
lapply(b$items$Termino, function(term) {
sym <- condition_symbol_qca(term, cond)
cls <- if (identical(sym, "●")) "paper-present" else if (identical(sym, "⊗")) "paper-absent" else "paper-blank"
tags$td(class = cls, condition_symbol_tag_qca(sym))
})
}), recursive = FALSE)
do.call(tags$tr, c(list(tags$th(class = "paper-stub", unname(conds[[cond]]))), cells))
})
metric_row <- function(label, field) {
cells <- unlist(lapply(blocks, function(b) {
lapply(b$items[[field]], function(v) tags$td(class = "paper-number", paper_num(v, 2)))
}), recursive = FALSE)
do.call(tags$tr, c(list(tags$th(class = "paper-stub paper-metric", label)), cells))
}
overall_row <- function(label, field) {
cells <- lapply(blocks, function(b) tags$td(class = "paper-number paper-overall", colspan = nrow(b$items), paper_num(b[[field]], 2)))
do.call(tags$tr, c(list(tags$th(class = "paper-stub paper-metric", label)), cells))
}
div(
class = "paper-table-wrap",
div(class = "paper-caption", paste("fsQCA presence and absence of", outcome)),
tags$table(
class = "paper-qca-table",
tags$thead(
tags$tr(tags$th(class = "paper-stub", "System"), tags$th(class = "paper-group", colspan = total_cols, report_system_label(rv))),
do.call(tags$tr, c(list(tags$th(class = "paper-stub", outcome), group_cells))),
do.call(tags$tr, c(list(tags$th(class = "paper-stub", "Configurations")), config_cells))
),
tags$tbody(
condition_rows,
metric_row("Raw Coverage", "Cobertura_bruta"),
metric_row("Unique Coverage", "Cobertura_unica"),
metric_row("Consistency", "Consistencia"),
overall_row("Overall coverage", "overall_coverage"),
overall_row("Overall consistency", "overall_consistency")
)
),
div(class = "paper-note", tags$em("Note:"), " black circles (●) indicate the presence of the condition and circles with an x (⊗) indicate their absence. Blank space: not relevant condition (do not care).")
)
}
write_visual_report_html <- function(file, rv) {
body <- as.character(report_solution_matrix_ui(rv))
css <- "
body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif; color: #1f2a32; margin: 28px; }
.paper-table-wrap { overflow-x: auto; }
.paper-caption { font-size: 15px; line-height: 1.35; margin-bottom: 10px; color: #111; }
.paper-qca-table { width: 100%; min-width: 760px; border-collapse: collapse; table-layout: fixed; font-size: 13px; color: #111; background: #fff; }
.paper-qca-table th, .paper-qca-table td { border: 0; border-bottom: 1px solid #d7d7d7; padding: 7px 8px; text-align: center; vertical-align: middle; }
.paper-qca-table thead tr:first-child th { border-top: 2px solid #111; }
.paper-qca-table thead tr:last-child th { border-bottom: 1.5px solid #111; }
.paper-qca-table tbody tr:last-child th, .paper-qca-table tbody tr:last-child td { border-bottom: 2px solid #111; }
.paper-qca-table .paper-stub { width: 210px; text-align: left; font-weight: 400; }
.paper-qca-table thead .paper-stub, .paper-qca-table .paper-group, .paper-qca-table .paper-config, .paper-qca-table .paper-metric { font-weight: 600; }
.paper-present, .paper-absent { font-size: 18px; line-height: 1; font-family: 'Segoe UI Symbol', 'Arial Unicode MS', sans-serif; }
.paper-number { font-variant-numeric: tabular-nums; }
.paper-overall { font-weight: 600; background: #fafafa; }
.paper-note { font-size: 12px; line-height: 1.4; color: #222; margin-top: 8px; }
"
html <- paste0(
"Reporte visual fsQCA",
body,
""
)
writeLines(html, file, useBytes = TRUE)
}
make_reproduce_r <- function(rv) {
lines <- c(
"# Replicabilidad - Módulo fsQCA",
"# Script generado automáticamente como bitácora operativa.",
"library(haven)",
"library(QCA)",
"library(openxlsx)",
"",
"# 1. Cargar datos y aplicar la misma segmentación usada en la app.",
"# 2. Reproducir calibraciones variable por variable.",
"# 3. Ejecutar necesidad, tablas de la verdad, minimización y robustez.",
""
)
if (!is.null(rv$file_meta$filename)) {
lines <- c(lines, paste0("# Archivo original: ", rv$file_meta$filename))
}
if (!is.null(rv$model)) {
lines <- c(lines,
"",
"# Modelo",
paste0("outcome_raw <- ", deparse(rv$model$outcome)),
paste0("conds_raw <- c(", paste(vapply(rv$model$conditions, deparse, character(1)), collapse = ", "), ")"),
paste0("model_scope <- ", deparse(rv$model$scope))
)
}
if (length(rv$profiles) > 0) {
lines <- c(lines, "", "# Calibraciones aplicadas")
for (p in rv$profiles) {
lines <- c(lines,
paste0("# ", p$variable, ": método=", p$method, "; anclas=", paste(p$thresholds, collapse = ", "), "; política_05=", p$half_policy %||% "warn")
)
}
}
lines <- c(lines, "", "# Nota: este script es una bitácora inicial. La versión siguiente exportará código ejecutable completo con la ruta de datos confirmada.")
paste(lines, collapse = "\n")
}
ui <- fluidPage(
tags$head(
tags$title("Módulo fsQCA"),
tags$style(HTML("
:root {
--ink: #1f2a32;
--muted: #66727c;
--line: #d8dee2;
--paper: #fbfbf9;
--panel: #ffffff;
--accent: #176f6b;
--accent-2: #8a2635;
--gold: #b7842f;
--deep: #132026;
}
html, body { min-height: 100%; }
body {
background: var(--paper);
color: var(--ink);
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif;
}
.app-shell {
display: grid;
grid-template-columns: 284px minmax(520px, 1fr) 372px;
gap: 18px;
padding: 18px;
}
.app-shell.tanguito-collapsed {
grid-template-columns: 284px minmax(520px, 1fr) 72px;
}
.left-rail, .main-stage, .tanguito-panel {
border: 1px solid var(--line);
background: var(--panel);
border-radius: 8px;
}
.left-rail {
min-height: calc(100vh - 36px);
padding: 16px;
position: sticky;
top: 18px;
align-self: start;
}
.brand {
border-bottom: 1px solid var(--line);
padding-bottom: 14px;
margin-bottom: 14px;
}
.brand h1 {
font-size: 21px;
margin: 0;
letter-spacing: 0;
}
.brand p {
color: var(--muted);
margin: 5px 0 0;
font-size: 13px;
line-height: 1.35;
}
.step-button {
width: 100%;
text-align: left;
border: 1px solid var(--line);
background: #ffffff;
color: var(--ink);
padding: 10px 11px;
border-radius: 8px;
margin-bottom: 8px;
box-shadow: none;
white-space: normal;
}
.step-button.active {
border-color: var(--accent);
background: #eef7f5;
font-weight: 700;
}
.step-button.locked {
color: #8a949b;
background: #f4f5f4;
}
.main-stage {
min-height: calc(100vh - 36px);
padding: 22px;
}
.step-title {
display: flex;
align-items: flex-start;
justify-content: space-between;
gap: 16px;
border-bottom: 1px solid var(--line);
padding-bottom: 14px;
margin-bottom: 18px;
}
.step-title h2 {
margin: 0;
font-size: 24px;
letter-spacing: 0;
}
.step-title p {
margin: 6px 0 0;
color: var(--muted);
max-width: 760px;
line-height: 1.45;
}
.panel-card {
border: 1px solid var(--line);
border-radius: 8px;
background: #fff;
padding: 16px;
margin-bottom: 14px;
}
.panel-card h3 {
margin-top: 0;
font-size: 16px;
}
.panel-card .form-group {
margin-bottom: 14px;
}
.field-help,
.panel-card > .small-note {
display: block;
margin-top: 7px;
margin-bottom: 18px;
max-width: 760px;
}
.panel-card > .small-note:last-child,
.field-help:last-child {
margin-bottom: 0;
}
.action-row {
display: flex;
flex-wrap: wrap;
gap: 10px;
align-items: center;
margin-top: 18px;
padding-top: 14px;
border-top: 1px solid var(--line);
}
.section-label {
margin: 18px 0 8px;
font-size: 14px;
font-weight: 800;
color: var(--ink);
}
.method-box {
border: 1px solid var(--line);
border-radius: 8px;
background: #fbfbfb;
padding: 12px;
margin: 10px 0 14px;
}
.method-box strong {
display: block;
margin-bottom: 4px;
}
.metric-grid {
display: grid;
grid-template-columns: repeat(4, minmax(120px, 1fr));
gap: 10px;
}
.metric {
border: 1px solid var(--line);
border-radius: 8px;
padding: 10px;
background: #fbfbfb;
}
.metric span {
display: block;
color: var(--muted);
font-size: 12px;
}
.metric strong {
display: block;
font-size: 20px;
margin-top: 3px;
}
.model-live-grid {
display: grid;
grid-template-columns: minmax(230px, .8fr) minmax(280px, 1.2fr);
gap: 14px;
}
.model-live-box {
border: 1px solid var(--line);
border-radius: 8px;
background: #fbfbfb;
padding: 13px;
min-height: 120px;
}
.model-live-box h4 {
margin: 0 0 10px;
font-size: 13px;
color: var(--muted);
text-transform: uppercase;
letter-spacing: .04em;
}
.model-live-box strong {
display: block;
font-size: 18px;
line-height: 1.2;
overflow-wrap: anywhere;
}
.model-live-detail {
color: var(--muted);
margin-top: 7px;
line-height: 1.35;
}
.model-chip-list {
display: flex;
flex-wrap: wrap;
gap: 7px;
}
.model-chip {
border: 1px solid #cfd7d9;
background: #eef4f5;
border-radius: 999px;
padding: 5px 9px;
font-size: 12px;
color: var(--ink);
}
.condition-row {
display: grid;
grid-template-columns: minmax(180px, 1.2fr) minmax(180px, 1fr) minmax(160px, .85fr);
gap: 12px;
align-items: end;
border-bottom: 1px solid #eef0f1;
padding: 10px 0;
}
.condition-name {
font-weight: 700;
color: var(--ink);
padding-bottom: 8px;
}
.condition-picker select {
min-height: 220px;
}
.condition-help {
color: var(--muted);
font-size: 12px;
margin-top: -4px;
margin-bottom: 10px;
}
.condition-dual-grid {
display: grid;
grid-template-columns: 1fr 1fr;
gap: 12px;
}
.condition-box {
border: 1px solid var(--line);
border-radius: 8px;
background: #fbfbfb;
min-height: 260px;
padding: 10px;
}
.condition-box h4 {
margin: 0 0 8px;
font-size: 13px;
color: var(--muted);
}
.condition-option {
padding: 8px 9px;
border: 1px solid #dfe5e7;
background: #fff;
border-radius: 7px;
margin-bottom: 6px;
cursor: pointer;
user-select: none;
}
.condition-option:hover {
border-color: var(--accent);
background: #f1f7f7;
}
.condition-selected-item {
display: flex;
align-items: center;
justify-content: space-between;
gap: 8px;
padding: 8px 9px;
border: 1px solid #cfd7d9;
background: #eef4f5;
border-radius: 7px;
margin-bottom: 6px;
}
.condition-remove {
border: 0;
background: #ffffff;
color: var(--accent-2);
border-radius: 999px;
width: 24px;
height: 24px;
line-height: 20px;
font-weight: 700;
}
.tanguito-stage {
position: relative;
min-height: 112px;
display: flex;
align-items: center;
gap: 14px;
}
.tanguito-orbit {
position: relative;
width: 96px;
height: 96px;
flex: 0 0 96px;
perspective: 600px;
}
.tanguito-bot {
position: absolute;
inset: 8px;
border-radius: 26px;
background: linear-gradient(145deg, #f8fbfb 0%, #d5e1e3 48%, #9dafb5 100%);
box-shadow: 0 18px 28px rgba(0,0,0,.34), inset -10px -12px 22px rgba(53,72,78,.22), inset 10px 10px 18px rgba(255,255,255,.78);
transform: rotateX(8deg) rotateY(-12deg);
}
.tanguito-bot:before {
content: '';
position: absolute;
left: 18px;
right: 18px;
top: 22px;
height: 31px;
border-radius: 15px;
background: linear-gradient(145deg, #122832, #08131a);
box-shadow: inset 0 0 0 1px rgba(255,255,255,.08);
}
.tanguito-bot:after {
content: '';
position: absolute;
left: 37px;
top: -14px;
width: 8px;
height: 18px;
border-radius: 8px;
background: #176f6b;
box-shadow: 0 -7px 0 2px #b7842f;
}
.tanguito-eye {
position: absolute;
top: 33px;
width: 8px;
height: 8px;
border-radius: 50%;
background: #66e0ce;
box-shadow: 0 0 12px #66e0ce;
z-index: 2;
}
.tanguito-eye.left { left: 30px; }
.tanguito-eye.right { right: 30px; }
.tanguito-smile {
position: absolute;
left: 35px;
top: 45px;
width: 26px;
height: 12px;
border-bottom: 4px solid #f0c878;
border-radius: 0 0 18px 18px;
z-index: 2;
}
.tanguito-shadow {
position: absolute;
left: 18px;
right: 18px;
bottom: 1px;
height: 15px;
border-radius: 50%;
background: rgba(0,0,0,.28);
filter: blur(5px);
}
.locked-box {
border: 1px dashed var(--line);
border-radius: 8px;
padding: 18px;
background: #f8f8f6;
color: var(--muted);
}
.btn-primary, .btn-default.action-button.primary-action {
background: var(--accent);
color: white;
border-color: var(--accent);
}
.btn-default.action-button.secondary-action {
background: #ffffff;
color: var(--accent);
border-color: var(--accent);
}
.reset-stage {
border: 1px solid #d9a24c;
background: #fff3df;
color: #7b4a05;
border-radius: 8px;
padding: 8px 12px;
font-weight: 600;
white-space: nowrap;
}
.reset-stage:hover {
background: #ffe8c2;
border-color: #bf7d20;
}
.welcome-shell {
min-height: 100vh;
padding: 32px;
display: flex;
align-items: center;
justify-content: center;
}
.welcome-hero {
width: min(1180px, 100%);
min-height: min(720px, calc(100vh - 64px));
display: grid;
grid-template-columns: minmax(280px, .85fr) minmax(320px, 1.15fr);
gap: 28px;
align-items: center;
border: 1px solid var(--line);
border-radius: 8px;
background: #fff;
padding: 32px;
}
.welcome-art {
display: flex;
justify-content: center;
}
.welcome-art img {
width: min(360px, 90%);
height: auto;
}
.welcome-copy h2 {
margin: 0 0 12px;
font-size: 34px;
letter-spacing: 0;
}
.welcome-copy p {
color: var(--muted);
font-size: 16px;
line-height: 1.5;
max-width: 720px;
}
.module-card-grid {
display: grid;
grid-template-columns: repeat(2, minmax(220px, 1fr));
gap: 12px;
margin: 22px 0;
}
.module-card {
border: 1px solid var(--line);
border-radius: 8px;
background: #fff;
padding: 15px;
}
.module-card-action {
width: 100%;
color: var(--ink);
text-align: left;
box-shadow: none;
white-space: normal;
cursor: pointer;
}
.module-card-action:hover,
.module-card-action:focus {
border-color: var(--accent);
background: #eef7f5;
color: var(--ink);
}
.module-card strong {
display: block;
margin-bottom: 5px;
}
.module-card.disabled {
background: #f6f7f6;
color: #89939a;
}
.tanguito-panel {
height: calc(100vh - 36px);
position: sticky;
top: 18px;
display: flex;
flex-direction: column;
overflow: hidden;
background: #111c22;
color: #f3f6f6;
}
.tanguito-panel.collapsed .tanguito-log,
.tanguito-panel.collapsed .chat-input,
.tanguito-panel.collapsed .tanguito-head p {
display: none;
}
.tanguito-panel.collapsed .tanguito-stage {
flex-direction: column;
min-height: auto;
}
.tanguito-panel.collapsed .tanguito-orbit {
width: 44px;
height: 44px;
flex-basis: 44px;
}
.tanguito-panel.collapsed .tanguito-head {
padding: 10px 8px;
}
.tanguito-panel.collapsed .tanguito-head h2 {
font-size: 12px;
text-align: center;
}
.tanguito-head {
padding: 16px;
border-bottom: 1px solid rgba(255,255,255,.12);
background:
radial-gradient(circle at 14% 16%, rgba(183,132,47,.35), transparent 24%),
linear-gradient(145deg, #182b33 0%, #101a20 100%);
}
.tanguito-head h2 {
margin: 0;
font-size: 22px;
}
.tanguito-head p {
margin: 4px 0 0;
color: #bdc8cc;
font-size: 13px;
line-height: 1.35;
}
.tanguito-log {
flex: 1;
overflow-y: auto;
padding: 14px;
}
.msg {
border-radius: 8px;
padding: 10px 11px;
margin-bottom: 10px;
background: #20323b;
border: 1px solid rgba(255,255,255,.08);
line-height: 1.38;
max-width: 88%;
}
.msg.usuario {
margin-left: auto;
background: #176f6b;
border-color: rgba(255,255,255,.16);
}
.msg.info,
.msg.sugerencia,
.msg.advertencia,
.msg.bloqueo,
.msg.decision,
.msg.interpretacion,
.msg.reporte {
margin-right: auto;
}
.msg .meta {
display: flex;
justify-content: space-between;
color: #a9b6ba;
font-size: 11px;
margin-bottom: 4px;
}
.msg.sugerencia { border-left: 4px solid var(--gold); }
.msg.advertencia { border-left: 4px solid #d67b43; }
.msg.bloqueo { border-left: 4px solid #d4555d; }
.msg.decision { border-left: 4px solid var(--accent); }
.msg.interpretacion { border-left: 4px solid #7ba6d8; }
.msg.reporte { border-left: 4px solid #b7c88b; }
.chat-input {
padding: 12px;
border-top: 1px solid rgba(255,255,255,.12);
background: #16262e;
}
.tanguito-local-note {
border: 1px solid rgba(255,255,255,.12);
border-radius: 8px;
padding: 8px 9px;
margin-bottom: 10px;
background: rgba(255,255,255,.04);
color: #c8d1d4;
font-size: 12px;
line-height: 1.35;
}
.chat-input textarea {
background: #0f1a20;
color: #f3f6f6;
border-color: rgba(255,255,255,.2);
}
.small-note {
color: var(--muted);
font-size: 12px;
line-height: 1.4;
}
.paper-table-wrap {
overflow-x: auto;
padding: 6px 2px 2px;
}
.paper-caption {
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif;
font-size: 15px;
line-height: 1.35;
margin-bottom: 10px;
color: #111;
}
.paper-qca-table {
width: 100%;
min-width: 760px;
border-collapse: collapse;
table-layout: fixed;
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif;
font-size: 13px;
color: #111;
background: #fff;
}
.paper-qca-table th,
.paper-qca-table td {
border: 0;
border-bottom: 1px solid #d7d7d7;
padding: 7px 8px;
text-align: center;
vertical-align: middle;
}
.paper-qca-table thead tr:first-child th {
border-top: 2px solid #111;
}
.paper-qca-table thead tr:last-child th {
border-bottom: 1.5px solid #111;
}
.paper-qca-table tbody tr:last-child th,
.paper-qca-table tbody tr:last-child td {
border-bottom: 2px solid #111;
}
.paper-qca-table .paper-stub {
width: 210px;
text-align: left;
font-weight: 400;
}
.paper-qca-table thead .paper-stub,
.paper-qca-table .paper-group,
.paper-qca-table .paper-config,
.paper-qca-table .paper-metric {
font-weight: 600;
}
.paper-present,
.paper-absent {
font-size: 18px;
line-height: 1;
font-family: 'Segoe UI Symbol', 'Arial Unicode MS', -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif;
}
.paper-number {
font-variant-numeric: tabular-nums;
}
.paper-overall {
font-weight: 600;
background: #fafafa;
}
.paper-note {
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', sans-serif;
font-size: 12px;
line-height: 1.4;
color: #222;
margin-top: 8px;
}
pre {
background: #101820;
color: #f1f4f4;
border-radius: 8px;
border: 0;
padding: 13px;
white-space: pre-wrap;
}
@media (max-width: 1200px) {
.app-shell { grid-template-columns: 240px 1fr; }
.tanguito-panel { grid-column: 1 / -1; height: 420px; position: static; }
}
@media (max-width: 860px) {
.app-shell { grid-template-columns: 1fr; padding: 10px; }
.left-rail { min-height: auto; position: static; }
.condition-row { grid-template-columns: 1fr; }
.condition-dual-grid { grid-template-columns: 1fr; }
.model-live-grid { grid-template-columns: 1fr; }
.metric-grid { grid-template-columns: repeat(2, minmax(120px, 1fr)); }
.welcome-shell { padding: 12px; align-items: flex-start; }
.welcome-hero { grid-template-columns: 1fr; padding: 18px; }
.module-card-grid { grid-template-columns: 1fr; }
}
"))
,
tags$script(HTML("
$(document).on('shiny:value', function(event) {
if (event.name === 'tanguito_log') {
setTimeout(function() {
var log = document.querySelector('.tanguito-log');
if (log) log.scrollTop = log.scrollHeight;
}, 60);
}
});
$(document).on('dblclick', '.condition-option', function() {
Shiny.setInputValue('add_condition_dbl', $(this).data('var'), {priority: 'event'});
});
$(document).on('click', '.condition-remove', function(e) {
e.preventDefault();
Shiny.setInputValue('remove_condition_click', $(this).data('var'), {priority: 'event'});
});
Shiny.addCustomMessageHandler('toggleTanguito', function(x) {
$('.app-shell').toggleClass('tanguito-collapsed', x.collapsed);
$('.tanguito-panel').toggleClass('collapsed', x.collapsed);
$('#toggle_tanguito').text(x.collapsed ? 'Abrir' : 'Minimizar');
});
"))
),
uiOutput("app_ui")
)
server <- function(input, output, session) {
rv <- reactiveValues(
current_step = 0L,
raw_data = NULL,
active_data = NULL,
labels = NULL,
missing = NULL,
file_meta = NULL,
segment_label = NULL,
model = NULL,
profiles = list(),
calibrated = NULL,
necessity = list(),
truth = list(),
solutions = list(),
robustness = NULL,
curated = list(),
explore_var = NULL,
selected_conditions = character(0),
tanguito_collapsed = FALSE,
assistant = data.frame(
time = character(0),
type = character(0),
step = character(0),
message = character(0),
stringsAsFactors = FALSE
)
)
current_step_title <- function() {
if (identical(as.integer(rv$current_step), 0L)) return(welcome_step_title)
steps$title[steps$id == rv$current_step]
}
step_header <- function(title, subtitle, step) {
div(
class = "step-title",
div(h2(title), p(subtitle)),
tags$button(
type = "button",
class = "reset-stage",
onclick = sprintf("Shiny.setInputValue('reset_from_stage', %d, {priority: 'event'});", step),
"Resetear desde esta etapa"
)
)
}
tanguito <- function(type = "info", message, step = current_step_title()) {
new <- data.frame(
time = format(Sys.time(), "%H:%M:%S"),
type = type,
step = step,
message = message,
stringsAsFactors = FALSE
)
rv$assistant <- rbind(rv$assistant, new)
if (nrow(rv$assistant) > 200) rv$assistant <- tail(rv$assistant, 200)
}
invalidate_after <- function(stage) {
if (stage %in% c("data", "model", "calibration")) {
rv$necessity <- list()
rv$truth <- list()
rv$solutions <- list()
rv$robustness <- NULL
}
if (stage %in% c("truth")) {
rv$solutions <- list()
rv$robustness <- NULL
}
if (stage %in% c("solutions")) {
rv$robustness <- NULL
}
}
reset_from_step <- function(step) {
if (step <= 1) {
rv$active_data <- NULL
rv$model <- NULL
rv$profiles <- list()
rv$calibrated <- NULL
rv$necessity <- list()
rv$truth <- list()
rv$solutions <- list()
rv$robustness <- NULL
rv$curated <- list()
rv$selected_conditions <- character(0)
rv$explore_var <- NULL
rv$segment_label <- NULL
rv$current_step <- 1L
tanguito("decision", "Reinicio desde el paso 1. Conservé el archivo cargado, pero borré preparación, modelo y resultados.")
return(invisible(NULL))
}
if (step == 2) {
rv$model <- NULL
rv$profiles <- list()
rv$calibrated <- NULL
rv$necessity <- list()
rv$truth <- list()
rv$solutions <- list()
rv$robustness <- NULL
rv$curated <- list()
rv$selected_conditions <- character(0)
rv$explore_var <- NULL
rv$current_step <- 2L
tanguito("decision", "Reinicio desde modelizar. El dataset queda preparado; vuelve a elegir outcome y condiciones.")
return(invisible(NULL))
}
if (step == 3 && !is.null(rv$model)) {
rv$profiles <- list()
rv$profiles[[rv$model$outcome]] <- default_profile(rv$model$outcome, rv$model$outcome_role)
for (v in rv$model$conditions) rv$profiles[[v]] <- default_profile(v, rv$model$condition_roles[[v]])
rv$calibrated <- NULL
rv$necessity <- list()
rv$truth <- list()
rv$solutions <- list()
rv$robustness <- NULL
rv$curated <- list()
rv$explore_var <- NULL
rv$current_step <- 3L
tanguito("decision", "Reinicio desde calibración. El modelo se conserva; vuelve a aplicar las calibraciones.")
return(invisible(NULL))
}
if (step == 4) {
rv$necessity <- list()
rv$truth <- list()
rv$solutions <- list()
rv$robustness <- NULL
rv$curated <- list()
rv$current_step <- 4L
tanguito("decision", "Reinicio desde necesidad. Las calibraciones se conservan.")
return(invisible(NULL))
}
if (step == 5) {
rv$truth <- list()
rv$solutions <- list()
rv$robustness <- NULL
rv$curated <- list()
rv$current_step <- 5L
tanguito("decision", "Reinicio desde tablas de la verdad. Necesidad y calibraciones se conservan.")
return(invisible(NULL))
}
if (step == 6) {
rv$solutions <- list()
rv$robustness <- NULL
rv$curated <- list()
rv$current_step <- 6L
tanguito("decision", "Reinicio desde soluciones. Las tablas de la verdad se conservan.")
return(invisible(NULL))
}
if (step == 7) {
rv$robustness <- NULL
rv$current_step <- 7L
tanguito("decision", "Reinicio desde reporte. Las soluciones se conservan; robustez se limpia.")
return(invisible(NULL))
}
if (step == 8) {
rv$robustness <- NULL
rv$current_step <- 8L
tanguito("decision", "Reinicio desde robustez. Las soluciones se conservan.")
}
}
reset_all_to_welcome <- function() {
rv$current_step <- 0L
rv$raw_data <- NULL
rv$active_data <- NULL
rv$labels <- NULL
rv$missing <- NULL
rv$file_meta <- NULL
rv$segment_label <- NULL
rv$model <- NULL
rv$profiles <- list()
rv$calibrated <- NULL
rv$necessity <- list()
rv$truth <- list()
rv$solutions <- list()
rv$robustness <- NULL
rv$curated <- list()
rv$explore_var <- NULL
rv$selected_conditions <- character(0)
rv$tanguito_collapsed <- FALSE
rv$assistant <- data.frame(
time = character(0),
type = character(0),
step = character(0),
message = character(0),
stringsAsFactors = FALSE
)
}
observeEvent(TRUE, {
tanguito(
"info",
"¡Hola tanguero! ¿Nos tomamos un mate mientras trabajamos?"
)
}, once = TRUE)
welcome_ui <- function() {
div(
class = "welcome-shell",
div(
class = "welcome-hero",
div(class = "welcome-art", tags$img(src = "tanguito-mate.svg", alt = "Tanguito con mate")),
div(
class = "welcome-copy",
h2("Tanguito"),
p("Bienvenido. Esta app nace para mejorar la experiencia de usuario, reducir la fricción y demostrar que puedes crear módulos de forma ágil y amigable con IA y R, adaptados a tus propias demandas de research. Está construida con librerías de R y el apoyo de Codex, con la idea de que te animes a desarrollar tus propias herramientas."),
p(class = "small-note", "Juan Bruno | jbruno@umh.es"),
div(
class = "module-card-grid",
actionButton(
"enter_fsqca",
label = tagList(
strong("Módulo fsQCA"),
span("Calibración, necesidad, tablas de la verdad, soluciones, robustez y reportes publicables.")
),
class = "module-card module-card-action"
),
div(class = "module-card disabled", strong("Módulo SEM"), span("Próximamente.")),
div(class = "module-card disabled", strong("Módulo Random Forest"), span("Próximamente.")),
div(class = "module-card disabled", strong("Process"), span("Arquitectura preparada para crecer."))
)
)
)
)
}
module_shell_ui <- function() {
div(
class = paste("app-shell", if (isTRUE(rv$tanguito_collapsed)) "tanguito-collapsed" else ""),
div(
class = "left-rail",
div(class = "brand", h1("Módulo fsQCA"), p("Flujo guiado para calibrar, analizar, interpretar y reportar fsQCA/QCA.")),
uiOutput("step_nav"),
div(class = "small-note", "Tanguito está en modo beta: orienta, explica y registra decisiones, pero el criterio final es del investigador."),
div(class = "small-note", "Autoría: Juan Bruno, jbruno@umh.es")
),
div(
class = "main-stage",
uiOutput("step_body")
),
div(
class = paste("tanguito-panel", if (isTRUE(rv$tanguito_collapsed)) "collapsed" else ""),
div(
class = "tanguito-head",
div(
class = "tanguito-stage",
div(
class = "tanguito-orbit",
div(class = "tanguito-shadow"),
div(class = "tanguito-bot", div(class = "tanguito-eye left"), div(class = "tanguito-eye right"), div(class = "tanguito-smile"))
),
div(h2("Tanguito"), p("Copiloto fsQCA en modo beta. Te ayuda a leer el proceso.")),
actionButton("toggle_tanguito", if (isTRUE(rv$tanguito_collapsed)) "Abrir" else "Minimizar", class = "secondary-action")
)
),
div(class = "tanguito-log", uiOutput("tanguito_log")),
div(
class = "chat-input",
textAreaInput("tanguito_text", NULL, placeholder = "Pregúntale a Tanguito sobre fsQCA...", rows = 3),
actionButton("tanguito_send", "Enviar", class = "primary-action", width = "100%")
)
)
)
}
output$app_ui <- renderUI({
if (identical(as.integer(rv$current_step), 0L)) welcome_ui() else module_shell_ui()
})
observeEvent(input$toggle_tanguito, {
rv$tanguito_collapsed <- !isTRUE(rv$tanguito_collapsed)
session$sendCustomMessage("toggleTanguito", list(collapsed = rv$tanguito_collapsed))
})
step_available <- reactive({
ready_cal <- FALSE
if (!is.null(rv$model)) {
vars <- c(rv$model$outcome, rv$model$conditions)
ready_cal <- all(vapply(vars, function(v) isTRUE(rv$profiles[[v]]$approved), logical(1)))
}
c(
TRUE,
!is.null(rv$active_data),
!is.null(rv$model),
!is.null(rv$model) && ready_cal,
!is.null(rv$calibrated) || (!is.null(rv$model) && ready_cal),
truth_has_object(rv$truth),
length(rv$solutions) > 0,
length(rv$solutions) > 0
)
})
output$step_nav <- renderUI({
avail <- step_available()
tagList(
actionButton("go_welcome", "Inicio", class = paste("step-button", if (rv$current_step == 0) "active" else "")),
lapply(seq_len(nrow(steps)), function(i) {
cls <- paste("step-button", if (rv$current_step == i) "active" else "", if (!avail[[i]]) "locked" else "")
actionButton(paste0("go_step_", i), steps$title[[i]], class = cls)
})
)
})
lapply(seq_len(nrow(steps)), function(i) {
observeEvent(input[[paste0("go_step_", i)]], {
if (!step_available()[[i]]) {
tanguito("bloqueo", paste("Este paso aún no está listo. Primero completa:", steps$title[max(which(step_available()))]))
return(NULL)
}
rv$current_step <- i
}, ignoreInit = TRUE)
})
observeEvent(input$go_welcome, {
showModal(modalDialog(
title = "Salir del módulo fsQCA",
"Vas a salir del módulo y se limpiará el trabajo actual: archivo cargado, modelo, calibraciones, tablas, soluciones y reportes. Para volver a trabajar deberás empezar nuevamente.",
footer = tagList(
modalButton("Cancelar"),
actionButton("confirm_go_welcome", "Salir y volver al inicio", class = "reset-stage")
),
easyClose = FALSE
))
}, ignoreInit = TRUE)
observeEvent(input$confirm_go_welcome, {
removeModal()
reset_all_to_welcome()
}, ignoreInit = TRUE)
observeEvent(input$enter_fsqca, {
rv$current_step <- 1L
tanguito("decision", "Entramos al módulo fsQCA. Empezamos cargando la base de datos.")
}, ignoreInit = TRUE)
observeEvent(input$reset_from_stage, {
reset_from_step(as.integer(input$reset_from_stage))
})
output$tanguito_log <- renderUI({
if (nrow(rv$assistant) == 0) return(NULL)
tagList(lapply(seq_len(nrow(rv$assistant)), function(i) {
row <- rv$assistant[i, ]
div(
class = paste("msg", row$type),
div(class = "meta", span(row$type), span(row$time)),
div(HTML(htmltools::htmlEscape(row$message)))
)
}))
})
answer_tanguito <- function(txt) {
tanguito_local_answer(txt, rv, input)
}
observeEvent(input$tanguito_send, {
req(input$tanguito_text)
txt <- trimws(input$tanguito_text)
if (!nzchar(txt)) return(NULL)
tanguito("usuario", txt)
ans <- answer_tanguito(txt)
tanguito("interpretacion", ans)
updateTextAreaInput(session, "tanguito_text", value = "")
})
observeEvent(input$file, {
req(input$file)
loaded <- try(read_uploaded_data(input$file$datapath, input$file$name), silent = TRUE)
if (inherits(loaded, "try-error")) {
tanguito("bloqueo", paste("No pude leer el archivo. El detalle técnico fue:", as.character(loaded), "Si es SPSS, puede venir con etiquetas no estándar; ahora el lector intenta convertir etiquetas múltiples en texto seguro."))
showNotification(as.character(loaded), type = "error")
return(NULL)
}
rv$raw_data <- loaded$data
rv$labels <- loaded$labels
rv$file_meta <- list(
filename = loaded$filename,
source = loaded$source,
rows_original = nrow(loaded$data),
cols_original = ncol(loaded$data),
loaded_at = as.character(Sys.time())
)
rv$missing <- missing_profile(loaded$data)
rv$active_data <- NULL
rv$model <- NULL
rv$profiles <- list()
rv$calibrated <- NULL
rv$selected_conditions <- character(0)
rv$explore_var <- NULL
invalidate_after("data")
tanguito(
"info",
paste0(
"Dataset cargado: ", nrow(loaded$data), " casos y ", ncol(loaded$data),
" variables desde ", loaded$source, ". Ahora prepara el dataset, con segmentación si corresponde."
)
)
})
output$segment_controls <- renderUI({
req(rv$raw_data)
vars <- names(rv$raw_data)
tagList(
selectInput("id_var", "ID del caso (opcional)", choices = c("No usar ID" = "", var_choices(vars, rv$labels)), selected = ""),
div(class = "small-note field-help", "El ID identifica cada caso u observación. No entra al modelo; solo ayuda a rastrear casos."),
selectInput("segment_var", "Variable de segmentación (opcional)", choices = c("Sin segmentar" = "", var_choices(vars, rv$labels)), selected = ""),
div(class = "small-note field-help", "Segmentar significa trabajar con un subset de la muestra, por ejemplo solo edad, región o variables de un clúster."),
uiOutput("segment_value_ui")
)
})
output$segment_value_ui <- renderUI({
req(rv$raw_data)
if (is.null(input$segment_var) || !nzchar(input$segment_var)) return(NULL)
vals <- unique(rv$raw_data[[input$segment_var]])
vals <- vals[!is.na(vals)]
if (length(vals) > 250) {
textInput("segment_value", "Valor a conservar", placeholder = "Escribe el valor exacto")
} else {
selectInput("segment_value", "Valor a conservar", choices = as.character(vals))
}
})
observeEvent(input$prepare_data, {
req(rv$raw_data)
datos <- rv$raw_data
segment_note <- "Sin segmentar"
rv$segment_label <- "Modelo completo"
if (!is.null(input$segment_var) && nzchar(input$segment_var)) {
req(input$segment_value)
before <- nrow(datos)
datos <- datos[!is.na(datos[[input$segment_var]]) & as.character(datos[[input$segment_var]]) == as.character(input$segment_value), , drop = FALSE]
if (nrow(datos) == 0) {
tanguito("bloqueo", "La segmentación dejó 0 casos. Cambia el valor o vuelve a sin segmentación.")
showNotification("La segmentación dejó 0 casos.", type = "error")
return(NULL)
}
segment_note <- paste0(input$segment_var, " = ", input$segment_value, " (", nrow(datos), " de ", before, " casos)")
rv$segment_label <- paste0(input$segment_var, " = ", input$segment_value)
}
rv$active_data <- datos
rv$missing <- missing_profile(datos)
rv$model <- NULL
rv$profiles <- list()
rv$calibrated <- NULL
rv$selected_conditions <- character(0)
rv$explore_var <- NULL
invalidate_after("data")
rv$current_step <- 2L
tanguito("decision", paste("Bien, has completado el paso 1. Dataset preparado.", segment_note, "N analítico:", nrow(datos), "Avancemos al paso 2: definir el modelo."))
})
output$conditions_picker <- renderUI({
req(rv$active_data)
if (is.null(input$outcome_var) || !nzchar(input$outcome_var)) {
return(div(class = "locked-box", "Primero elige el outcome. Luego se habilitan las condiciones."))
}
selected <- intersect(rv$selected_conditions %||% character(0), setdiff(names(rv$active_data), input$outcome_var))
available <- setdiff(names(rv$active_data), c(input$outcome_var, selected))
query <- trimws(input$condition_search %||% "")
if (nzchar(query)) {
haystack <- vapply(available, function(v) paste(v, var_label(v, rv$labels)), character(1))
available <- available[grepl(query, haystack, ignore.case = TRUE, fixed = TRUE)]
}
if (length(available) == 0 && length(selected) == 0) {
return(div(class = "locked-box", "No hay variables disponibles como condiciones con ese criterio de búsqueda."))
}
tagList(
div(class = "condition-help", "Doble clic en una variable para agregarla como condición. Para quitarla, usa el icono ×. Tanguito sugiere no usar más de 6 condiciones salvo que tengas una razón teórica fuerte."),
div(class = "condition-dual-grid",
div(class = "condition-box",
h4("Variables disponibles"),
if (length(available) == 0) div(class = "small-note", "No quedan variables disponibles.") else tagList(lapply(available, function(v) {
div(class = "condition-option", `data-var` = v, title = "Doble clic para agregar", var_label(v, rv$labels))
}))
),
div(class = "condition-box",
h4("Condiciones"),
if (length(selected) == 0) div(class = "small-note", "Todavía no agregaste condiciones.") else tagList(lapply(selected, function(v) {
div(class = "condition-selected-item",
span(var_label(v, rv$labels)),
tags$button(type = "button", class = "condition-remove", `data-var` = v, "×")
)
}))
)
)
)
})
observeEvent(input$add_condition_dbl, {
req(rv$active_data, input$outcome_var)
v <- input$add_condition_dbl
if (is.null(v) || !nzchar(v) || identical(v, input$outcome_var)) return(NULL)
rv$selected_conditions <- unique(c(rv$selected_conditions, v))
if (length(rv$selected_conditions) > 6) {
tanguito("advertencia", "Agregaste más de 6 condiciones. El número de configuraciones crece muy rápido; conviene sostenerlo con teoría.")
}
}, ignoreInit = TRUE)
observeEvent(input$remove_condition_click, {
v <- input$remove_condition_click
rv$selected_conditions <- setdiff(rv$selected_conditions, v)
}, ignoreInit = TRUE)
observeEvent(input$outcome_var, {
if (!is.null(input$outcome_var) && nzchar(input$outcome_var)) {
rv$selected_conditions <- setdiff(rv$selected_conditions, input$outcome_var)
}
}, ignoreInit = TRUE)
output$outcome_target_ui <- renderUI({
req(rv$active_data)
if (!identical(input$outcome_role, "crisp_multivalue")) return(NULL)
req(input$outcome_var)
mv <- try(map_multivalue(rv$active_data[[input$outcome_var]]), silent = TRUE)
if (inherits(mv, "try-error")) return(div(class = "locked-box", "No hay categorías válidas para este outcome."))
vals <- sort(unique(na.omit(mv$values)))
if (length(vals) == 0) return(div(class = "locked-box", "No hay categorías válidas para este outcome."))
selectInput("outcome_target", "Categoría del outcome a explicar", choices = vals, selected = vals[1], multiple = TRUE, selectize = FALSE, size = min(8, length(vals)))
})
output$condition_roles_ui <- renderUI({
req(rv$active_data)
vars <- rv$selected_conditions %||% character(0)
if (length(vars) == 0) return(div(class = "locked-box", "Selecciona condiciones para definir su tipo y sentido esperado."))
tagList(lapply(vars, function(v) {
div(
class = "condition-row",
div(class = "condition-name", var_label(v, rv$labels)),
selectInput(
var_input_id("role", v, rv$active_data),
"Tipo",
choices = c(
"Valor original (sin calibrar)" = "fuzzy_raw",
"Fuzzy calibrado (0-1)" = "fuzzy_calibrated",
"Binario (0/1)" = "crisp_binary",
"Multivalor / categórico" = "crisp_multivalue"
),
selected = if (is_calibrated_01(rv$active_data[[v]])) "fuzzy_calibrated" else if (is_binary_01(rv$active_data[[v]])) "crisp_binary" else "fuzzy_raw"
),
selectInput(
var_input_id("dir", v, rv$active_data),
"Expectativa direccional",
choices = c("Presencia ayuda al outcome" = "present", "Ausencia ayuda al outcome" = "absent", "Sin expectativa" = "none"),
selected = "none"
)
)
}))
})
observeEvent(input$save_model, {
req(rv$active_data)
if (is.null(input$outcome_var) || !nzchar(input$outcome_var)) {
tanguito("bloqueo", "Antes de modelizar debes elegir el outcome.")
showNotification("Elige el outcome.", type = "warning")
return(NULL)
}
conds <- rv$selected_conditions %||% character(0)
if (length(conds) == 0) {
tanguito("bloqueo", "El modelo necesita al menos una condición.")
showNotification("Selecciona al menos una condición.", type = "error")
return(NULL)
}
if (input$outcome_var %in% conds) {
tanguito("bloqueo", "El outcome no puede ser también condición.")
showNotification("El outcome no puede ser condición.", type = "error")
return(NULL)
}
guess_role <- function(v) {
x <- rv$active_data[[v]]
if (is_binary_01(x)) return("crisp_binary")
if (is_calibrated_01(x)) return("fuzzy_calibrated")
"fuzzy_raw"
}
vars <- c(input$outcome_var, conds)
internal_map <- make_internal_map(vars)
model <- list(
outcome = input$outcome_var,
outcome_role = input$outcome_role %||% "fuzzy_raw",
outcome_target = paste(input$outcome_target %||% "", collapse = ","),
conditions = conds,
condition_roles = stats::setNames(vapply(conds, guess_role, character(1)), conds),
directions = stats::setNames(rep("none", length(conds)), conds),
scope = input$model_scope %||% "presence",
internal_map = internal_map,
saved_at = as.character(Sys.time())
)
rv$model <- model
rv$profiles <- list()
rv$profiles[[model$outcome]] <- default_profile(model$outcome, model$outcome_role)
for (v in model$conditions) rv$profiles[[v]] <- default_profile(v, model$condition_roles[[v]])
rv$calibrated <- NULL
invalidate_after("model")
rv$current_step <- 3L
configs <- prod(vapply(model$conditions, function(v) {
if (identical(model$condition_roles[[v]], "crisp_multivalue")) max(2, length(unique(na.omit(rv$active_data[[v]])))) else 2
}, numeric(1)))
msg <- paste0("Modelo guardado: outcome ", model$outcome, ", ", length(conds), " condiciones, alcance: ", model$scope, ". Configuraciones posibles aproximadas: ", configs, ".")
tanguito("decision", paste("Bien, has completado el paso 2.", msg, "Avancemos al paso 3: explorar y aplicar calibraciones."))
if (length(conds) > 6) {
tanguito("advertencia", "Tanguito te marca algo importante: con más de 6 condiciones las tablas de la verdad crecen mucho. Revisa si todas son teóricamente indispensables.")
}
if (configs > nrow(rv$active_data)) {
tanguito("advertencia", "Hay más configuraciones posibles que casos. Esto puede producir diversidad limitada; justifica el número de condiciones o considera reducir el modelo.")
}
})
observeEvent(input$calib_var, {
req(rv$model, input$calib_var)
prof <- rv$profiles[[input$calib_var]]
if (is.null(prof)) return(NULL)
updateSelectInput(session, "calib_role_type", selected = prof$role_type %||% "fuzzy_raw")
updateSelectInput(session, "calib_method", selected = prof$method)
updateCheckboxInput(session, "manual_mode", value = FALSE)
th <- prof$thresholds
if (length(th) == 3 && !all(is.na(th))) {
updateNumericInput(session, "anchor_excl", value = th[1])
updateNumericInput(session, "anchor_cross", value = th[2])
updateNumericInput(session, "anchor_incl", value = th[3])
}
if (!is.na(prof$crisp_threshold)) updateNumericInput(session, "crisp_threshold", value = prof$crisp_threshold)
if (identical(prof$method, "crisp_threshold_multi") && length(prof$thresholds) > 0 && !all(is.na(prof$thresholds))) {
updateTextInput(session, "crisp_thresholds_multi", value = paste(prof$thresholds, collapse = ", "))
}
updateTextAreaInput(session, "calib_note", value = prof$note %||% "")
}, ignoreInit = TRUE)
observeEvent(input$open_calib_var, {
req(input$calib_var)
rv$explore_var <- input$calib_var
tanguito("info", paste("Explorando calibración para", input$calib_var, ". Compara las opciones de literatura, la distribución empírica y tu criterio teórico."))
})
set_anchors_from_suggestion <- function(which) {
req(rv$active_data, input$calib_var)
sug <- calibration_suggestions(rv$active_data[[input$calib_var]])
idx <- grep(which, sug$Propuesta, ignore.case = TRUE)
if (length(idx) == 0) {
tanguito("advertencia", paste("No encontré una propuesta", which, "para", input$calib_var, ". Revisa las sugerencias disponibles."))
return(NULL)
}
row <- sug[idx[1], , drop = FALSE]
vals <- suppressWarnings(as.numeric(strsplit(row$Anchors, ",\\s*")[[1]]))
if (length(vals) == 3 && !any(is.na(vals))) {
if (vals[1] > vals[3]) vals <- c(vals[3], vals[2], vals[1])
updateNumericInput(session, "anchor_excl", value = vals[1])
updateNumericInput(session, "anchor_cross", value = vals[2])
updateNumericInput(session, "anchor_incl", value = vals[3])
updateSelectInput(session, "calib_method", selected = "fuzzy_direct")
updateTextAreaInput(session, "calib_note", value = row$Texto_reporte)
tanguito("sugerencia", paste("Cargué la propuesta", row$Propuesta, "para", input$calib_var, ". Revisa si tiene sentido teórico antes de aplicarla."))
}
}
observeEvent(input$use_likert, set_anchors_from_suggestion("Likert"))
observeEvent(input$use_p10, set_anchors_from_suggestion("P10"))
observeEvent(input$use_p5, set_anchors_from_suggestion("P5"))
observeEvent(input$use_p20, set_anchors_from_suggestion("P20"))
observeEvent(input$apply_calibration, {
req(rv$model, rv$active_data, input$calib_var)
profile <- rv$profiles[[input$calib_var]] %||% default_profile(input$calib_var, "fuzzy_raw")
role_type <- input$calib_role_type %||% profile$role_type %||% "fuzzy_raw"
profile$role_type <- role_type
if (identical(role_type, "fuzzy_calibrated")) {
profile$method <- "fuzzy_calibrated"
profile$criterion <- "Fuzzy calibrado (0-1), sin recalibrar"
profile$thresholds <- c(NA_real_, NA_real_, NA_real_)
profile$crisp_threshold <- NA_real_
profile$note <- input$calib_note %||% ""
} else if (identical(role_type, "crisp_binary")) {
profile$method <- "crisp_binary"
profile$criterion <- "Binario observado (0/1), sin recalibrar"
profile$thresholds <- c(NA_real_, NA_real_, NA_real_)
profile$crisp_threshold <- NA_real_
profile$note <- input$calib_note %||% ""
} else if (identical(role_type, "crisp_multivalue")) {
profile$method <- "crisp_multivalue"
profile$criterion <- "Multivalor / categórico observado, sin recalibrar"
profile$thresholds <- c(NA_real_, NA_real_, NA_real_)
profile$crisp_threshold <- NA_real_
profile$note <- input$calib_note %||% ""
} else if (!isTRUE(input$manual_mode)) {
choice <- input$calib_choice %||% "manual"
sug <- calibration_suggestions(rv$active_data[[input$calib_var]])
idx <- suppressWarnings(as.integer(choice))
if (!is.na(idx) && idx >= 1 && idx <= nrow(sug)) {
profile$method <- sug$Metodo[idx]
profile$criterion <- sug$Propuesta[idx]
vals <- suppressWarnings(as.numeric(strsplit(sug$Anchors[idx], ",\\s*")[[1]]))
if (identical(profile$method, "fuzzy_direct") && length(vals) == 3 && !any(is.na(vals))) {
if (vals[1] > vals[3]) vals <- c(vals[3], vals[2], vals[1])
profile$thresholds <- vals
}
user_note <- trimws(input$calib_note %||% "")
profile$note <- if (nzchar(user_note)) paste(sug$Texto_reporte[idx], "Justificación del investigador:", user_note) else sug$Texto_reporte[idx]
} else {
tanguito("bloqueo", "Selecciona una sugerencia de calibración o activa calibración manual / literatura propia.")
showNotification("Selecciona una calibración.", type = "warning")
return(NULL)
}
} else {
profile$method <- input$calib_method
profile$criterion <- "Manual / literatura propia"
if (identical(profile$method, "crisp_threshold_multi")) {
profile$thresholds <- parse_thresholds_free(input$crisp_thresholds_multi %||% "")
} else {
profile$thresholds <- c(input$anchor_excl %||% NA_real_, input$anchor_cross %||% NA_real_, input$anchor_incl %||% NA_real_)
}
profile$crisp_threshold <- input$crisp_threshold %||% NA_real_
profile$note <- input$calib_note %||% ""
}
profile$half_policy <- if (profile$method %in% c("fuzzy_direct", "fuzzy_calibrated")) input$global_half_policy %||% "warn" else "no aplica"
profile$approved <- TRUE
profile$updated <- as.character(Sys.time())
trial <- try(apply_profile_vector(rv$active_data[[input$calib_var]], profile), silent = TRUE)
if (inherits(trial, "try-error")) {
tanguito("bloqueo", paste("No pude aplicar la calibración de", input$calib_var, ":", as.character(trial)))
showNotification(as.character(trial), type = "error")
return(NULL)
}
rv$profiles[[input$calib_var]] <- profile
if (identical(input$calib_var, rv$model$outcome)) {
rv$model$outcome_role <- role_type
} else if (input$calib_var %in% rv$model$conditions) {
rv$model$condition_roles[[input$calib_var]] <- role_type
}
rv$calibrated <- NULL
invalidate_after("calibration")
msg <- paste0("Calibración aplicada para ", input$calib_var, " con criterio ", profile$criterion %||% profile$method, ".")
if (trial$half_n > 0) msg <- paste0(msg, " Detecté ", trial$half_n, " casos exactamente en 0.5; política global: ", input$global_half_policy %||% "warn", ".")
tanguito("decision", msg)
})
calibration_ready <- reactive({
if (is.null(rv$model)) return(FALSE)
vars <- c(rv$model$outcome, rv$model$conditions)
all(vapply(vars, function(v) isTRUE(rv$profiles[[v]]$approved), logical(1)))
})
observeEvent(input$go_need_after_calib, {
if (!calibration_ready()) {
tanguito("bloqueo", "Todavía faltan calibraciones por aplicar. Revisa el resumen: todas las variables deben figurar como calibradas antes de avanzar.")
showNotification("Faltan calibraciones por aplicar.", type = "warning")
return(NULL)
}
rv$current_step <- 4L
tanguito("decision", "Bien, has completado el paso 3. Calibraciones aplicadas. Avancemos al paso 4: análisis de necesidad.")
})
ensure_calibrated <- function() {
if (!calibration_ready()) stop("Faltan variables por calibrar/aplicar.")
rv$calibrated <- build_calibrated_project(rv$active_data, rv$model, rv$profiles, input$global_half_policy %||% "warn")
if (rv$calibrated$dropped > 0) {
tanguito("advertencia", paste("Se excluyeron", rv$calibrated$dropped, "casos por missing en variables del modelo."))
}
rv$calibrated
}
observeEvent(input$run_necessity, {
req(rv$model)
cal <- try(ensure_calibrated(), silent = TRUE)
if (inherits(cal, "try-error")) {
tanguito("bloqueo", as.character(cal))
showNotification(as.character(cal), type = "error")
return(NULL)
}
rv$necessity <- list()
nec_conds <- necessity_condition_set(rv$model, rv$profiles)
conds <- nec_conds$internal
label_map <- cal$label_map
if (length(nec_conds$excluded) > 0) {
tanguito("info", paste(
"Necesidad se calcula solo con condiciones fuzzy calibradas. Excluí de necesidad:",
paste(nec_conds$excluded, collapse = ", "),
"porque son binarias, multivalor/categóricas o fueron definidas sin calibración fuzzy."
))
}
if (length(nec_conds$internal) == 0) {
msg <- "No hay condiciones fuzzy calibradas para analizar necesidad. Puedes avanzar a las tablas de la verdad; las condiciones binarias o multivalor se usan allí, no en necesidad."
for (dir in model_directions(rv$model$scope)) {
rv$necessity[[dir]] <- data.frame(Mensaje = msg, stringsAsFactors = FALSE)
}
tanguito("advertencia", msg)
return(NULL)
}
for (dir in model_directions(rv$model$scope)) {
nec_data <- build_necessity_data(rv$model, cal, dir)
po <- try(QCA::pofind(data = nec_data$data, outcome = nec_data$outcome, conditions = conds, relation = "necessity"), silent = TRUE)
if (inherits(po, "try-error")) {
msg <- explain_qca_error(po, paste("El análisis de necesidad para", direction_label(dir)))
rv$necessity[[dir]] <- data.frame(Error = msg)
tanguito("bloqueo", msg)
next
}
mat <- po$incl.cov
tab <- data.frame(Condicion = rownames(mat), mat, row.names = NULL, check.names = FALSE)
tab$Outcome_modelado <- direction_label(dir)
nec_cut_val <- suppressWarnings(as.numeric(input$nec_cut %||% .90))
tab$Candidata_necesaria <- if ("inclN" %in% names(tab)) suppressWarnings(as.numeric(tab$inclN)) >= nec_cut_val else if ("incl" %in% names(tab)) suppressWarnings(as.numeric(tab$incl)) >= nec_cut_val else NA
names(tab)[names(tab) == "Condicion"] <- "Condición"
names(tab)[names(tab) == "Outcome_modelado"] <- "Outcome modelado"
names(tab)[names(tab) == "Candidata_necesaria"] <- "Candidata necesaria"
tab[["Candidata necesaria"]] <- ifelse(tab[["Candidata necesaria"]] %in% TRUE, "Sí", "No")
rv$necessity[[dir]] <- relabel_df(tab, label_map)
}
tanguito("interpretacion", "Bien, has completado el paso 4. Necesidad ejecutada. Revisa las tablas antes de avanzar: una condicion con consistencia alta puede ser candidata necesaria, pero no equivale a una solucion suficiente.")
})
observeEvent(input$run_truth, {
req(rv$model)
cal <- try(ensure_calibrated(), silent = TRUE)
if (inherits(cal, "try-error")) {
tanguito("bloqueo", as.character(cal))
showNotification(as.character(cal), type = "error")
return(NULL)
}
rv$truth <- list()
conds <- unname(rv$model$internal_map[rv$model$conditions])
for (dir in model_directions(rv$model$scope)) {
out_spec <- build_outcome_spec(rv$model, cal, dir)
cuts <- truth_cutoffs_for(input, dir)
tt <- try(QCA::truthTable(
data = cal$data,
outcome = out_spec,
conditions = conds,
incl.cut = cuts$incl,
pri.cut = cuts$pri,
n.cut = cuts$n,
complete = TRUE,
sort.by = c("OUT", "incl", "n"),
show.cases = TRUE
), silent = TRUE)
if (inherits(tt, "try-error")) {
msg <- explain_qca_error(tt, paste("Las tablas de la verdad para", direction_label(dir)))
rv$truth[[dir]] <- list(
error = msg,
counts = data.frame(OUT = "Error", Frecuencia = NA_integer_, Descripcion = msg, stringsAsFactors = FALSE),
table = data.frame(Error = msg, stringsAsFactors = FALSE)
)
tanguito("bloqueo", msg)
next
}
tt_df <- as.data.frame(if (!is.null(tt$tt)) tt$tt else tt)
counts <- truth_counts(tt)
diagnosis <- diagnose_truth_table(counts, length(conds), nrow(cal$data))
rv$truth[[dir]] <- list(
object = tt,
table = relabel_df(tt_df, cal$label_map),
counts = counts,
diagnosis = diagnosis
)
tanguito("interpretacion", paste(direction_label(dir), diagnosis))
if (!truth_has_out1(rv$truth[[dir]])) {
tanguito("advertencia", paste(direction_label(dir), "no tiene configuraciones OUT=1. Con estos cortes no habrá solución suficiente para ese modelo."))
}
}
if (!truth_has_object(rv$truth)) {
tanguito("bloqueo", "No se pudo construir ninguna tabla válida dentro de las tablas de la verdad. Revisa las calibraciones y los tipos de condiciones antes de avanzar.")
return(NULL)
}
if (!truth_has_any_out1(rv$truth)) {
tanguito("bloqueo", "Las tablas de la verdad se construyeron, pero no hay configuraciones OUT=1. No conviene avanzar a soluciones: revisa cutoffs, calibración y condiciones.")
return(NULL)
}
tanguito("decision", "Bien, has completado el cálculo de las tablas de la verdad. Revisa el resumen de configuraciones OUT antes de avanzar al paso 6.")
})
observeEvent(input$go_solutions_after_truth, {
if (!truth_has_object(rv$truth)) {
tanguito("bloqueo", "Primero construye las tablas de la verdad válidas.")
showNotification("Primero construye las tablas de la verdad.", type = "warning")
return(NULL)
}
if (!truth_has_any_out1(rv$truth)) {
tanguito("bloqueo", "No hay configuraciones OUT=1. Con estos cortes no hay base para minimizar soluciones.")
showNotification("No hay configuraciones OUT=1.", type = "warning")
return(NULL)
}
rv$current_step <- 6L
tanguito("decision", "Avancemos al paso 6: revisar soluciones compleja, intermedia y parsimoniosa.")
})
observeEvent(input$go_truth_after_nec, {
rv$current_step <- 5L
tanguito("decision", "Avancemos al paso 5: construir las tablas de la verdad. Puedes usar cortes distintos para presencia y ausencia si estás estimando ambos modelos.")
})
observeEvent(input$run_solutions, {
req(rv$model, rv$truth)
if (!truth_has_object(rv$truth)) {
tanguito("bloqueo", "No hay tablas de la verdad válidas para minimizar. Vuelve al paso 5 y revisa el resumen OUT.")
showNotification("Primero construye las tablas de la verdad válidas.", type = "warning")
return(NULL)
}
if (!truth_has_any_out1(rv$truth)) {
tanguito("bloqueo", "No hay configuraciones OUT=1. QCA no puede minimizar soluciones sin filas explicables.")
showNotification("No hay configuraciones OUT=1.", type = "warning")
return(NULL)
}
cal <- rv$calibrated
if (is.null(cal)) cal <- ensure_calibrated()
rv$solutions <- list()
method <- input$min_method %||% "CCubes"
dir_exp <- dir_exp_vector(rv$model)
for (dir in names(rv$truth)) {
if (is.null(rv$truth[[dir]]$object)) next
if (!truth_has_out1(rv$truth[[dir]])) {
tanguito("advertencia", paste(direction_label(dir), "no se minimiza porque no tiene configuraciones OUT=1."))
next
}
tt <- rv$truth[[dir]]$object
sol_complex <- try(QCA::minimize(tt, method = method, include = "1", details = TRUE, show.cases = FALSE, first.min = TRUE, all.sol = FALSE), silent = TRUE)
sol_pars <- try(QCA::minimize(tt, method = method, include = "?", details = TRUE, show.cases = FALSE, first.min = TRUE, all.sol = FALSE), silent = TRUE)
sol_inter <- try(QCA::minimize(tt, method = method, include = "?", dir.exp = dir_exp, details = TRUE, show.cases = FALSE, first.min = TRUE, all.sol = FALSE), silent = TRUE)
if (inherits(sol_inter, "try-error")) {
tanguito("advertencia", explain_qca_error(sol_inter, paste("La solución intermedia para", direction_label(dir))))
}
prefix <- if (dir == "presence") "P" else "A"
pars_txt <- solution_text(sol_pars)
inter_txt <- solution_text(sol_inter)
curated <- rv$curated[[dir]]
rv$solutions[[dir]] <- list(
complex = sol_complex,
pars = sol_pars,
inter = sol_inter,
complex_txt = solution_text(sol_complex),
pars_txt = pars_txt,
inter_txt = inter_txt,
complex_display_txt = solution_text_display(sol_complex, cal$label_map),
pars_display_txt = solution_text_display(sol_pars, cal$label_map),
inter_display_txt = solution_text_display(sol_inter, cal$label_map),
public_complex = make_public_solution_table(sol_complex, solution_text(sol_complex), prefix, cal$label_map, NULL),
public_pars = make_public_solution_table(sol_pars, pars_txt, prefix, cal$label_map, NULL),
public_inter = make_public_solution_table(sol_inter, inter_txt, prefix, cal$label_map, curated),
core = core_peripheral_table(pars_txt, inter_txt, cal$label_map, prefix),
overall_inter = overall_solution_fit(sol_inter)
)
}
if (length(rv$solutions) == 0) {
tanguito("bloqueo", "No se generó ninguna solución. Revisa el resumen OUT de las tablas de la verdad: si no hay configuraciones OUT=1, no hay base para minimizar.")
showNotification("No se generaron soluciones.", type = "warning")
return(NULL)
}
rv$current_step <- 6L
tanguito("interpretacion", paste("Minimización ejecutada con", method, ". Revisa la salida, cura la solución intermedia si corresponde y luego usa Crear reporte."))
})
observeEvent(input$go_robustness_optional, {
if (length(rv$solutions) == 0) {
tanguito("bloqueo", "Primero ejecuta las soluciones antes de robustez.")
showNotification("Primero ejecuta las soluciones.", type = "warning")
return(NULL)
}
rv$current_step <- 8L
tanguito("info", "Robustez es opcional. Úsala si quieres evaluar sensibilidad de cutoffs y preparar la tabla del material suplementario 5.")
})
observeEvent(input$save_curation, {
for (dir in names(rv$solutions)) {
id <- paste0("curated_", dir)
default_terms <- split_terms_qca(extract_formula_modelo_qca(rv$solutions[[dir]]$inter_txt %||% "", "M1"))
terms <- input[[id]] %||% default_terms
rv$curated[[dir]] <- list(included_terms = terms, reason = input$curation_reason %||% "")
prefix <- if (dir == "presence") "P" else "A"
if (!is.null(rv$solutions[[dir]]$inter) && !is.null(rv$calibrated$label_map)) {
rv$solutions[[dir]]$public_inter <- make_public_solution_table(
rv$solutions[[dir]]$inter,
rv$solutions[[dir]]$inter_txt %||% "",
prefix,
rv$calibrated$label_map,
rv$curated[[dir]]
)
}
}
tanguito("decision", "Curación guardada. El reporte visual usará solo las configuraciones incluidas.")
})
observeEvent(input$create_report, {
if (length(rv$solutions) == 0) {
tanguito("bloqueo", "Primero minimiza soluciones antes de crear el reporte.")
showNotification("Primero minimiza soluciones.", type = "warning")
return(NULL)
}
for (dir in names(rv$solutions)) {
id <- paste0("curated_", dir)
default_terms <- split_terms_qca(extract_formula_modelo_qca(rv$solutions[[dir]]$inter_txt %||% "", "M1"))
terms <- input[[id]] %||% default_terms
rv$curated[[dir]] <- list(included_terms = terms, reason = input$curation_reason %||% "")
prefix <- if (dir == "presence") "P" else "A"
if (!is.null(rv$solutions[[dir]]$inter) && !is.null(rv$calibrated$label_map)) {
rv$solutions[[dir]]$public_inter <- make_public_solution_table(
rv$solutions[[dir]]$inter,
rv$solutions[[dir]]$inter_txt %||% "",
prefix,
rv$calibrated$label_map,
rv$curated[[dir]]
)
}
}
rv$current_step <- 7L
tanguito("decision", "Reporte creado a partir de la solución intermedia curada. La robustez queda disponible como paso opcional.")
})
observeEvent(input$run_robustness, {
req(rv$model, rv$truth, rv$solutions)
cal <- rv$calibrated
conds <- unname(rv$model$internal_map[rv$model$conditions])
method <- input$min_method %||% "CCubes"
base_presence <- truth_cutoffs_for(input, "presence")
grid_ic <- parse_numeric_grid(input$sens_incl_grid, default = base_presence$incl)
grid_pc <- parse_numeric_grid(input$sens_pri_grid, default = base_presence$pri)
grid_nc <- parse_numeric_grid(input$sens_n_grid, default = base_presence$n, integer = TRUE)
if (length(grid_ic) == 0 || length(grid_pc) == 0 || length(grid_nc) == 0) {
tanguito("bloqueo", "Robustez necesita al menos un valor válido para consistencia, PRI y frecuencia.")
showNotification("Completa los cutoffs de robustez.", type = "warning")
return(NULL)
}
n_tests <- length(model_directions(rv$model$scope)) * length(grid_ic) * length(grid_pc) * length(grid_nc)
tanguito("advertencia", paste("Robustez puede tardar. Voy a ejecutar", n_tests, "pruebas de sensibilidad. Si el modelo tiene muchas condiciones, este paso puede ser lento."))
out_rows <- list()
for (dir in model_directions(rv$model$scope)) {
if (is.null(rv$solutions[[dir]])) next
ref_txt <- rv$solutions[[dir]]$inter_txt %||% ""
ref_formula <- extract_formula_modelo_qca(ref_txt, "M1")
ref_formula_public <- replace_qca_labels(ref_formula, cal$label_map)
out_spec <- build_outcome_spec(rv$model, cal, dir)
for (ic in grid_ic) for (pc in grid_pc) for (nc in grid_nc) {
nm <- paste0("incl", ic, "_pri", pc, "_n", nc)
if (length(model_directions(rv$model$scope)) > 1) nm <- paste0(if (dir == "presence") "presencia_" else "ausencia_", nm)
tt <- try(QCA::truthTable(cal$data, outcome = out_spec, conditions = conds, incl.cut = ic, pri.cut = pc, n.cut = nc, complete = TRUE, show.cases = FALSE), silent = TRUE)
if (inherits(tt, "try-error")) {
out_rows[[length(out_rows) + 1]] <- data.frame(
nombre = nm, incl_cut = ic, pri_cut = pc, n_cut = nc,
OUT1 = NA_integer_, OUT0 = NA_integer_, OUTq = NA_integer_,
inclS = NA_real_, PRI = NA_real_, covS = NA_real_,
`Solucion con nuevos cortes` = explain_qca_error(tt, "Robustez"),
`Solucion original` = ref_formula_public,
n_terms_sol = NA_integer_, n_terms_ref = length(split_terms_qca(ref_formula)),
n_terms_match = NA_integer_, match_pct = NA_real_, match_label = NA_character_,
Estabilidad = "No estable",
check.names = FALSE,
stringsAsFactors = FALSE
)
next
}
counts <- truth_counts(tt)
out1 <- truth_count_value(counts, "1")
out0 <- truth_count_value(counts, "0")
outq <- truth_count_value(counts, "?")
if (out1 == 0) {
out_rows[[length(out_rows) + 1]] <- data.frame(
nombre = nm, incl_cut = ic, pri_cut = pc, n_cut = nc,
OUT1 = out1, OUT0 = out0, OUTq = outq,
inclS = NA_real_, PRI = NA_real_, covS = NA_real_,
`Solucion con nuevos cortes` = "Sin configuraciones OUT=1",
`Solucion original` = ref_formula_public,
n_terms_sol = 0L, n_terms_ref = length(split_terms_qca(ref_formula)),
n_terms_match = 0L, match_pct = 0, match_label = "Baja",
Estabilidad = "No estable",
check.names = FALSE,
stringsAsFactors = FALSE
)
next
}
sol <- try(QCA::minimize(tt, method = method, include = "?", dir.exp = dir_exp_vector(rv$model), details = TRUE, show.cases = FALSE, first.min = TRUE, all.sol = FALSE), silent = TRUE)
if (inherits(sol, "try-error")) {
out_rows[[length(out_rows) + 1]] <- data.frame(
nombre = nm, incl_cut = ic, pri_cut = pc, n_cut = nc,
OUT1 = out1, OUT0 = out0, OUTq = outq,
inclS = NA_real_, PRI = NA_real_, covS = NA_real_,
`Solucion con nuevos cortes` = explain_qca_error(sol, "Robustez"),
`Solucion original` = ref_formula_public,
n_terms_sol = NA_integer_, n_terms_ref = length(split_terms_qca(ref_formula)),
n_terms_match = NA_integer_, match_pct = NA_real_, match_label = NA_character_,
Estabilidad = "No estable",
check.names = FALSE,
stringsAsFactors = FALSE
)
next
}
txt <- solution_text(sol)
formula <- extract_formula_modelo_qca(txt, "M1")
pm <- partial_match_qca(formula, ref_formula)
fit <- overall_solution_fit(sol)
cons <- fit$Valor[fit$Metrica == "Overall consistency"] %||% NA_real_
pri <- fit$Valor[fit$Metrica == "Overall PRI"] %||% NA_real_
cov <- fit$Valor[fit$Metrica == "Overall coverage"] %||% NA_real_
out_rows[[length(out_rows) + 1]] <- data.frame(
nombre = nm,
incl_cut = ic,
pri_cut = pc,
n_cut = nc,
OUT1 = out1,
OUT0 = out0,
OUTq = outq,
inclS = cons,
PRI = pri,
covS = cov,
`Solucion con nuevos cortes` = replace_qca_labels(formula, cal$label_map),
`Solucion original` = ref_formula_public,
n_terms_sol = pm$n_terms_sol,
n_terms_ref = pm$n_terms_ref,
n_terms_match = pm$n_terms_match,
match_pct = pm$match_pct,
match_label = pm$match_label,
Estabilidad = ifelse(!is.na(pm$match_pct) && pm$match_pct >= .75, "Estable", "No estable"),
check.names = FALSE,
stringsAsFactors = FALSE
)
}
}
if (length(out_rows) == 0) {
tanguito("bloqueo", "No se pudo ejecutar robustez porque no hay soluciones intermedias de referencia.")
showNotification("No hay soluciones de referencia para robustez.", type = "warning")
return(NULL)
}
rv$robustness <- do.call(rbind, out_rows)
rv$current_step <- 8L
stable <- mean(rv$robustness$Estabilidad == "Estable", na.rm = TRUE)
tanguito("interpretacion", paste0("Robustez ejecutada. ", round(stable * 100, 1), "% de escenarios retienen al menos 75% de la solución de referencia. Revisa el reporte de robustez en este paso."))
})
output$step_body <- renderUI({
if (identical(as.integer(rv$current_step), 0L)) {
return(NULL)
}
switch(
as.character(rv$current_step),
"1" = tagList(
step_header("Cargar datos", "Carga una base SPSS, Excel o CSV. En este paso puedes trabajar con toda la muestra o segmentarla; segmentar es analizar un subset de casos.", 1),
div(class = "panel-card",
fileInput("file", "Cargar archivo de datos", accept = c(".sav", ".xlsx", ".xls", ".csv")),
uiOutput("segment_controls"),
div(class = "action-row",
actionButton("prepare_data", "Avanzar a modelizar", class = "primary-action")
)
),
div(class = "panel-card", h3("Resumen archivo de datos"), uiOutput("data_metrics")),
div(class = "panel-card", checkboxInput("show_preview", "Previsualizar base de datos", value = FALSE), uiOutput("preview_panel"))
),
"2" = tagList(
step_header("Modelizar", "Elige el outcome, el alcance del modelo y las condiciones. La calibración de cada variable se decide en el paso siguiente.", 2),
if (is.null(rv$active_data)) div(class = "locked-box", "Primero prepara el dataset.") else tagList(
div(class = "panel-card",
h3("Selección del Outcome"),
selectInput("outcome_var", "Outcome", choices = c("Selecciona outcome" = "", var_choices(names(rv$active_data), rv$labels)), selected = ""),
selectInput("outcome_role", "Tipo de outcome para QCA", choices = c(
"Valor original (sin calibrar)" = "fuzzy_raw",
"Fuzzy calibrado (0-1)" = "fuzzy_calibrated",
"Binario (0/1)" = "crisp_binary",
"Multivalor / categórico" = "crisp_multivalue"
)),
uiOutput("outcome_target_ui"),
radioButtons("model_scope", "Modelo a estimar", choices = c("Presencia del outcome" = "presence", "Ausencia del outcome" = "absence", "Ambos" = "both"), selected = "presence", inline = TRUE),
h3("Selección de condiciones"),
textInput("condition_search", "Buscar condiciones", placeholder = "Escribe parte del nombre o etiqueta de la variable"),
uiOutput("conditions_picker")
),
div(class = "panel-card", h3("Modelo"), uiOutput("model_live_summary")),
div(class = "panel-card", actionButton("save_model", "Avanzar a explorar calibración", class = "primary-action"))
)
),
"3" = tagList(
step_header("Explorar y calibrar", "Primero revisa los descriptivos de las variables del modelo. Luego explora y aplica la calibración de cada variable antes de avanzar al análisis de necesidad.", 3),
if (is.null(rv$model)) div(class = "locked-box", "Primero guarda el modelo.") else tagList(
div(class = "panel-card",
h3("1. Descriptivos de las variables seleccionadas"),
DTOutput("model_metrics_table"),
div(class = "small-note", "Cortes QCA::findTh muestra el umbral exploratorio sugerido por el paquete QCA. Es una ayuda para pensar puntos de corte; no reemplaza la decisión teórica de calibración.")
),
div(class = "panel-card",
h3("2. Calibración por variable"),
uiOutput("calib_picker"),
actionButton("open_calib_var", "Explorar calibración variable seleccionada", class = "secondary-action")
),
uiOutput("variable_explorer"),
div(class = "panel-card",
h3("3. Resumen de calibraciones aplicadas"),
DTOutput("calibration_status"),
div(class = "small-note", "El resumen distingue variables calibradas y variables que no requieren calibración porque ya son fuzzy 0-1, binarias o multivalor/categóricas."),
div(class = "method-box",
strong("Política global para valores 0.5"),
radioButtons("global_half_policy", NULL, choices = c("Advertir y conservar" = "warn", "Mover 0.5 a 0.501" = "shift", "Excluir casos en 0.5" = "exclude"), selected = "warn", inline = TRUE),
div(class = "small-note", "Esta decisión se aplica a todas las variables fuzzy del modelo. En fsQCA, 0.5 es máxima ambigüedad respecto de la pertenencia al conjunto: el caso no está claramente más dentro que fuera. La decisión queda registrada en el resumen de calibración, el Excel y la sintaxis de replicabilidad.")
),
actionButton("go_need_after_calib", "Avanzar a necesidad", class = "primary-action")
)
)
),
"4" = tagList(
step_header("Necesidad", "Antes de analizar suficiencia, revisa si alguna condición puede considerarse necesaria para el outcome.", 4),
div(class = "panel-card",
radioButtons("nec_cut", "Umbral para marcar candidatas necesarias", choices = c("0.90 recomendado en literatura" = .90, "0.80 exploratorio" = .80, "0.70 muy exploratorio" = .70), selected = .90, inline = TRUE),
div(class = "small-note", "inclN es la consistencia de necesidad; covN es cobertura de necesidad; RoN ayuda a evaluar relevancia/no trivialidad."),
actionButton("run_necessity", "Analizar necesidad", class = "primary-action")
),
div(class = "panel-card", h3("Necesidad para presencia del outcome"), DTOutput("necessity_presence")),
div(class = "panel-card", h3("Necesidad para ausencia del outcome"), DTOutput("necessity_absence")),
actionButton("go_truth_after_nec", "Avanzar a tablas de la verdad", class = "primary-action")
),
"5" = tagList(
step_header("Tablas de la verdad", "Define los cortes y revisa cómo quedan clasificadas las configuraciones antes de minimizar soluciones.", 5),
div(class = "panel-card",
h3("Definir cutoffs por modelo"),
fluidRow(
column(4, h4("Presencia"), numericInput("incl_cut_presence", "Consistencia mínima", value = .80, min = 0, max = 1, step = .01), numericInput("pri_cut_presence", "PRI mínimo", value = .75, min = 0, max = 1, step = .01), numericInput("n_cut_presence", "Frecuencia mínima de casos", value = 1, min = 1, step = 1)),
column(4, h4("Ausencia"), numericInput("incl_cut_absence", "Consistencia mínima", value = .80, min = 0, max = 1, step = .01), numericInput("pri_cut_absence", "PRI mínimo", value = .75, min = 0, max = 1, step = .01), numericInput("n_cut_absence", "Frecuencia mínima de casos", value = 1, min = 1, step = 1)),
column(4,
checkboxInput("show_truth_tables", "Ver tablas de la verdad", value = FALSE),
div(class = "small-note", "Los cortes de presencia están en la primera columna y los de ausencia en la segunda. Si el modelo estima solo presencia o solo ausencia, se usa únicamente la columna correspondiente.")
)
),
div(class = "small-note", "OUT resume la clasificación de cada configuración: 1 = configuración suficiente para el outcome modelado; 0 = configuración que no entra en la solución; ? = configuración ambigua, insuficiente o no observada con los cortes elegidos."),
actionButton("run_truth", "Construir tablas de la verdad", class = "primary-action")
),
div(class = "panel-card", h3("Resumen de configuraciones (OUT)"), DTOutput("truth_counts")),
conditionalPanel(
condition = "input.show_truth_tables == true",
div(class = "panel-card", h3("Tablas de la verdad: presencia del outcome"), DTOutput("truth_presence")),
div(class = "panel-card", h3("Tablas de la verdad: ausencia del outcome"), DTOutput("truth_absence"))
),
actionButton("go_solutions_after_truth", "Avanzar a soluciones", class = "primary-action")
),
"6" = tagList(
step_header("Soluciones", "Ejecuta y revisa por separado las soluciones compleja, intermedia y parsimoniosa. La intermedia suele ser la base interpretativa principal.", 6),
div(class = "panel-card",
selectInput("min_method", "Algoritmo", choices = c("CCubes", "QMC", "eQMC"), selected = "CCubes"),
div(class = "small-note", "CCubes suele ser eficiente en R/QCA; QMC reproduce el algoritmo clásico Quine-McCluskey; eQMC es una variante optimizada."),
actionButton("run_solutions", "Minimizar soluciones", class = "primary-action")
),
div(class = "panel-card", h3("Soluciones del software QCA"), uiOutput("solutions_raw_tabs")),
div(class = "panel-card", h3("Curar configuraciones de la solución intermedia"), uiOutput("curation_ui"), textAreaInput("curation_reason", "Motivo para exclusiones", rows = 2), actionButton("save_curation", "Guardar curación", class = "secondary-action")),
div(class = "panel-card", actionButton("create_report", "Crear reporte", class = "primary-action"))
),
"7" = tagList(
step_header("Reporte", "Muestra las tablas finales para paper/suplemento. La robustez es opcional y no bloquea este reporte.", 7),
div(class = "panel-card",
downloadButton("download_xlsx", "Exportar Excel completo"),
downloadButton("download_rtf", "Exportar Material Suplementario"),
downloadButton("download_r_script", "Exportar sintaxis del modelo en R"),
downloadButton("download_visual_report", "Exportar reporte visual fsQCA")
),
div(class = "panel-card", h3("Reporte visual: soluciones fsQCA"), uiOutput("report_solution_tables")),
div(class = "panel-card", h3("Reporte de Robustez"), uiOutput("report_robustness_panel"))
),
"8" = tagList(
step_header("Robustez opcional", "Compara variaciones en cutoffs contra la solución intermedia de referencia. Este paso puede ser lento y puedes omitirlo si solo necesitas el reporte de soluciones.", 8),
div(class = "panel-card",
h3("Definir pruebas de sensibilidad"),
fluidRow(
column(4, textInput("sens_incl_grid", "Cutoffs de consistencia", value = ".75, .80, .85")),
column(4, textInput("sens_pri_grid", "Cutoffs PRI", value = "0, .05, .20")),
column(4, textInput("sens_n_grid", "Frecuencias mínimas n", value = "1, 4, 6"))
),
div(class = "small-note", "Escribe valores separados por coma. Robustez recalcula tablas de la verdad y solución intermedia para cada combinación; puede ser el paso más lento de todo el flujo."),
actionButton("run_robustness", "Ejecutar robustez", class = "primary-action"),
div(class = "small-note", "Tanguito avisará cuántas pruebas se ejecutarán antes de correrlas.")
),
div(class = "panel-card", h3("Tabla de robustez"), DTOutput("robustness_table"))
)
)
})
output$data_metrics <- renderUI({
if (is.null(rv$raw_data)) return(div(class = "locked-box", "Carga un archivo para ver métricas."))
datos <- rv$active_data %||% rv$raw_data
div(class = "metric-grid",
div(class = "metric", span("Casos"), strong(nrow(datos))),
div(class = "metric", span("Variables"), strong(ncol(datos))),
div(class = "metric", span("Fuente"), strong(rv$file_meta$source %||% "")),
div(class = "metric", span("Segmentación"), strong(if (is.null(rv$active_data)) "Sin aplicar" else if (!is.null(input$segment_var) && nzchar(input$segment_var)) "Segmentada" else "Sin segmentar"))
)
})
output$preview_panel <- renderUI({
if (!isTRUE(input$show_preview)) return(NULL)
tagList(h3("Previsualización"), DTOutput("data_preview"))
})
output$data_preview <- renderDT({
req(rv$raw_data)
datatable(head(rv$active_data %||% rv$raw_data, 100), options = list(scrollX = TRUE, pageLength = 8))
})
output$missing_table <- renderDT({
req(rv$missing)
datatable(rv$missing, options = list(scrollX = TRUE, pageLength = 8))
})
output$model_live_summary <- renderUI({
req(rv$active_data)
role_labels <- c(
fuzzy_raw = "Valor original (sin calibrar)",
fuzzy_calibrated = "Fuzzy calibrado (0-1)",
crisp_binary = "Binario (0/1)",
crisp_multivalue = "Multivalor / categórico"
)
scope_labels <- c(
presence = "Presencia del outcome",
absence = "Ausencia del outcome",
both = "Presencia y ausencia del outcome"
)
outcome <- input$outcome_var %||% rv$model$outcome %||% ""
outcome_role <- input$outcome_role %||% rv$model$outcome_role %||% ""
scope <- input$model_scope %||% rv$model$scope %||% "presence"
conds <- rv$selected_conditions %||% rv$model$conditions %||% character(0)
conds <- intersect(conds, setdiff(names(rv$active_data), outcome))
approx_configs <- if (length(conds) == 0) 0 else 2 ^ length(conds)
role_txt <- if (nzchar(outcome_role) && outcome_role %in% names(role_labels)) role_labels[[outcome_role]] else outcome_role
scope_txt <- if (nzchar(scope) && scope %in% names(scope_labels)) scope_labels[[scope]] else scope
div(
class = "model-live-grid",
div(
class = "model-live-box",
h4("Outcome"),
strong(if (nzchar(outcome)) var_label(outcome, rv$labels) else "Sin seleccionar"),
div(class = "model-live-detail", role_txt),
div(class = "model-live-detail", scope_txt)
),
div(
class = "model-live-box",
h4(paste0("Condiciones (", length(conds), ")")),
if (length(conds) == 0) {
div(class = "model-live-detail", "Todavía no elegiste condiciones.")
} else {
div(class = "model-chip-list", lapply(conds, function(v) div(class = "model-chip", var_label(v, rv$labels))))
},
div(class = "model-live-detail", paste("Configuraciones aproximadas:", approx_configs))
)
)
})
output$calib_picker <- renderUI({
req(rv$model)
vars <- c(rv$model$outcome, rv$model$conditions)
selectInput("calib_var", "Selecciona la variable a analizar", choices = var_choices(vars, rv$labels), selected = vars[1])
})
output$model_metrics_table <- renderDT({
req(rv$model, rv$active_data)
vars <- c(rv$model$outcome, rv$model$conditions)
datatable(
model_stats_table(rv$active_data, vars, rv$model$outcome),
options = list(scrollX = TRUE, paging = FALSE, searching = FALSE, info = FALSE, dom = "t")
)
})
output$variable_explorer <- renderUI({
req(rv$model, rv$active_data)
v <- rv$explore_var %||% input$calib_var
if (is.null(v) || !nzchar(v)) {
return(div(class = "locked-box", "Elige una variable y pulsa Explorar calibración variable seleccionada."))
}
sug <- calibration_suggestions(rv$active_data[[v]])
choices <- stats::setNames(as.character(seq_len(nrow(sug))), paste0(sug$Propuesta, " | ", sug$Anchors))
prof <- rv$profiles[[v]] %||% default_profile(v, "fuzzy_raw")
selected_role <- prof$role_type %||% "fuzzy_raw"
tagList(
div(class = "panel-card",
h3(paste("Explorando calibración:", var_label(v, rv$labels))),
plotOutput("calib_plot", height = 300),
selectInput("calib_role_type", "Tipo de variable para QCA", choices = role_type_choices, selected = selected_role),
uiOutput("calib_type_note"),
conditionalPanel(
condition = "input.calib_role_type == 'fuzzy_raw'",
h3("Sugerencias de calibración"),
DTOutput("calib_suggestions"),
radioButtons("calib_choice", "Selecciona una calibración", choices = choices, selected = if (length(choices) > 0) choices[[1]] else character(0)),
checkboxInput("manual_mode", "Usar calibración manual / literatura propia", value = FALSE),
conditionalPanel(
condition = "input.manual_mode == true",
selectInput("calib_method", "Tipo de calibración manual", choices = c(
"Fuzzy directa con tres anclas" = "fuzzy_direct",
"Binaria por punto de corte" = "crisp_threshold",
"Multivalor por varios puntos de corte" = "crisp_threshold_multi"
)),
conditionalPanel(
condition = "input.calib_method == 'fuzzy_direct'",
fluidRow(
column(4, numericInput("anchor_excl", "Ancla de exclusión", value = NA)),
column(4, numericInput("anchor_cross", "Punto de cruce", value = NA)),
column(4, numericInput("anchor_incl", "Ancla de inclusión", value = NA))
)
),
conditionalPanel(
condition = "input.calib_method == 'crisp_threshold'",
numericInput("crisp_threshold", "Punto de corte binario: transforma una variable en 0/1", value = NA),
div(class = "small-note", "Usa el punto de corte binario solo si quieres convertir una variable numérica en conjunto binario: valores iguales o superiores pasan a 1; el resto pasa a 0.")
),
conditionalPanel(
condition = "input.calib_method == 'crisp_threshold_multi'",
textInput("crisp_thresholds_multi", "Puntos de corte multivalor", placeholder = "Ejemplo: 170, 180"),
div(class = "small-note", "Según el manual QCA, crisp con dos cortes genera tres valores: 0, 1 y 2. Usa esta opción cuando una variable continua debe transformarse en condición crisp multivalor por criterio sustantivo.")
)
)
),
conditionalPanel(
condition = "input.calib_role_type != 'fuzzy_raw'",
uiOutput("non_fuzzy_calib_box")
),
textAreaInput("calib_note", "Justificación metodológica opcional para trazabilidad", placeholder = "Ejemplo: anclas definidas por literatura previa, percentiles de la muestra o criterio sustantivo.", rows = 3),
actionButton("apply_calibration", "Aplicar calibración a la variable seleccionada", class = "secondary-action")
)
)
})
output$calib_type_note <- renderUI({
req(rv$active_data, input$calib_var)
role_type <- input$calib_role_type %||% (rv$profiles[[input$calib_var]]$role_type %||% "fuzzy_raw")
div(class = "method-box", strong("Lectura de Tanguito"), calibration_type_guidance(rv$active_data[[input$calib_var]], role_type))
})
output$non_fuzzy_calib_box <- renderUI({
req(input$calib_role_type)
txt <- switch(
input$calib_role_type,
fuzzy_calibrated = "No se muestran anchors porque la variable ya está calibrada en 0-1. La app verificará el rango y registrará la decisión.",
crisp_binary = "No se muestran anchors porque una condición binaria expresa pertenencia/no pertenencia. Si tiene dos categorías observadas, la app las recodifica internamente a 0/1 y registra el mapeo.",
crisp_multivalue = "No se muestran anchors porque una condición multivalor usa categorías. La app las recodifica internamente en estados consecutivos para que QCA las lea correctamente.",
""
)
div(class = "method-box", strong("Sin recalibración"), txt)
})
output$calibration_status <- renderDT({
if (is.null(rv$model)) return(datatable(data.frame()))
vars <- c(rv$model$outcome, rv$model$conditions)
df <- do.call(rbind, lapply(vars, function(v) {
p <- rv$profiles[[v]]
data.frame(
Variable = v,
Rol = if (identical(v, rv$model$outcome)) "Outcome" else "Condición",
`Tipo de variable` = calibration_method_label(p$method),
Estado = if (!isTRUE(p$approved)) "Sin calibrar" else if (p$method %in% c("fuzzy_direct", "crisp_threshold", "crisp_threshold_multi")) "Calibrada" else "Lista (no requiere calibración)",
`Criterio elegido` = p$criterion %||% "Sin calibrar",
`Anclas / cortes aplicados` = if (identical(p$method, "fuzzy_direct") && !any(is.na(p$thresholds))) fmt_anchors(p$thresholds) else if (identical(p$method, "crisp_threshold_multi") && length(p$thresholds) > 0) paste(fmt3(p$thresholds), collapse = ", ") else if (identical(p$method, "crisp_threshold")) fmt3(p$crisp_threshold) else "No aplica",
stringsAsFactors = FALSE,
check.names = FALSE
)
}))
datatable(df, options = list(dom = "t", scrollX = TRUE))
})
output$calib_stats <- renderDT({
req(rv$active_data, input$calib_var)
st <- variable_stats(rv$active_data[[input$calib_var]])
st$Valor <- ifelse(is.numeric(st$Valor), compact_num(st$Valor), st$Valor)
datatable(st, options = list(dom = "t", pageLength = 20))
})
output$calib_suggestions <- renderDT({
req(rv$active_data, input$calib_var)
datatable(
calibration_suggestions_simple(rv$active_data[[input$calib_var]]),
options = list(scrollX = TRUE, paging = FALSE, searching = FALSE, info = FALSE, dom = "t")
)
})
output$findth_text <- renderText({
req(rv$active_data, input$calib_var)
findth_line(rv$active_data[[input$calib_var]])
})
output$calib_plot <- renderPlot({
req(rv$active_data, input$calib_var)
y <- numeric_values(rv$active_data[[input$calib_var]])
if (length(y) == 0) {
plot.new()
text(.5, .5, "Variable no numérica")
return()
}
hist(y, breaks = "FD", col = "#eef2f3", border = "#9aa7ad", main = input$calib_var, xlab = "Valor observado")
prof <- rv$profiles[[input$calib_var]]
if (!is.null(prof) && identical(prof$method, "fuzzy_direct") && !any(is.na(prof$thresholds))) {
abline(v = prof$thresholds, col = c("#8a2635", "#b7842f", "#176f6b"), lwd = 2)
legend("topright", legend = c("exclusión", "punto de cruce", "inclusión"), col = c("#8a2635", "#b7842f", "#176f6b"), lwd = 2, bty = "n", cex = .8)
}
})
output$necessity_presence <- renderDT({
df <- rv$necessity$presence %||% data.frame()
dt <- datatable(df, options = list(scrollX = TRUE, pageLength = 8))
nums <- names(df)[vapply(df, is.numeric, logical(1))]
if (length(nums)) dt <- formatRound(dt, nums, digits = 3)
dt
})
output$necessity_absence <- renderDT({
df <- rv$necessity$absence %||% data.frame()
dt <- datatable(df, options = list(scrollX = TRUE, pageLength = 8))
nums <- names(df)[vapply(df, is.numeric, logical(1))]
if (length(nums)) dt <- formatRound(dt, nums, digits = 3)
dt
})
output$truth_counts <- renderDT({
dfs <- lapply(names(rv$truth), function(dir) {
x <- rv$truth[[dir]]$counts
if (is.null(x)) return(NULL)
x$Modelo <- direction_label(dir)
x
})
datatable(if (length(dfs)) do.call(rbind, dfs) else data.frame(), options = list(scrollX = TRUE, pageLength = 8))
})
output$truth_presence <- renderDT({
datatable(rv$truth$presence$table %||% data.frame(), options = list(scrollX = TRUE, pageLength = 10))
})
output$truth_absence <- renderDT({
datatable(rv$truth$absence$table %||% data.frame(), options = list(scrollX = TRUE, pageLength = 10))
})
output$solution_presence <- renderDT({
datatable(rv$solutions$presence$public_inter %||% data.frame(), options = list(scrollX = TRUE, pageLength = 8))
})
output$solution_absence <- renderDT({
datatable(rv$solutions$absence$public_inter %||% data.frame(), options = list(scrollX = TRUE, pageLength = 8))
})
output$core_table <- renderDT({
dfs <- lapply(names(rv$solutions), function(dir) {
x <- rv$solutions[[dir]]$core
if (is.null(x)) return(NULL)
x$Modelo <- direction_label(dir)
x
})
datatable(if (length(dfs)) do.call(rbind, dfs) else data.frame(), options = list(scrollX = TRUE, pageLength = 10))
})
output$solutions_raw_tabs <- renderUI({
if (length(rv$solutions) == 0) return(div(class = "locked-box", "Ejecuta la minimización para ver las soluciones."))
tabs <- list()
if (!is.null(rv$solutions$presence)) {
tabs <- c(tabs, list(
tabPanel("Presencia - compleja", verbatimTextOutput("sol_presence_complex_txt")),
tabPanel("Presencia - intermedia", verbatimTextOutput("sol_presence_inter_txt")),
tabPanel("Presencia - parsimoniosa", verbatimTextOutput("sol_presence_pars_txt"))
))
}
if (!is.null(rv$solutions$absence)) {
tabs <- c(tabs, list(
tabPanel("Ausencia - compleja", verbatimTextOutput("sol_absence_complex_txt")),
tabPanel("Ausencia - intermedia", verbatimTextOutput("sol_absence_inter_txt")),
tabPanel("Ausencia - parsimoniosa", verbatimTextOutput("sol_absence_pars_txt"))
))
}
do.call(tabsetPanel, tabs)
})
output$sol_presence_complex_txt <- renderText(rv$solutions$presence$complex_display_txt %||% "Sin solución")
output$sol_presence_inter_txt <- renderText(rv$solutions$presence$inter_display_txt %||% "Sin solución")
output$sol_presence_pars_txt <- renderText(rv$solutions$presence$pars_display_txt %||% "Sin solución")
output$sol_absence_complex_txt <- renderText(rv$solutions$absence$complex_display_txt %||% "Sin solución")
output$sol_absence_inter_txt <- renderText(rv$solutions$absence$inter_display_txt %||% "Sin solución")
output$sol_absence_pars_txt <- renderText(rv$solutions$absence$pars_display_txt %||% "Sin solución")
output$curation_ui <- renderUI({
if (length(rv$solutions) == 0) return(div(class = "locked-box", "Ejecuta soluciones para curar configuraciones."))
tagList(lapply(names(rv$solutions), function(dir) {
sol_txt <- rv$solutions[[dir]]$inter_txt
terms <- split_terms_qca(extract_formula_modelo_qca(sol_txt, "M1"))
if (length(terms) == 0) return(NULL)
choices <- stats::setNames(terms, replace_qca_labels(terms, rv$calibrated$label_map))
checkboxGroupInput(paste0("curated_", dir), direction_label(dir), choices = choices, selected = terms)
}))
})
output$flower_presence <- renderPlot({
req(rv$solutions$presence, rv$calibrated)
plot_solution_flowers(rv$solutions$presence$inter_txt, rv$solutions$presence$pars_txt, unname(rv$model$internal_map[rv$model$conditions]), rv$calibrated$label_map, "P")
})
output$flower_absence <- renderPlot({
req(rv$solutions$absence, rv$calibrated)
plot_solution_flowers(rv$solutions$absence$inter_txt, rv$solutions$absence$pars_txt, unname(rv$model$internal_map[rv$model$conditions]), rv$calibrated$label_map, "A")
})
output$solution_text <- renderText({
paste(
"Presencia\n", rv$solutions$presence$inter_display_txt %||% "Sin solución",
"\n\nAusencia\n", rv$solutions$absence$inter_display_txt %||% "Sin solución"
)
})
output$robustness_table <- renderDT({
tab <- rv$robustness %||% data.frame()
wanted <- c("nombre", "incl_cut", "pri_cut", "n_cut", "OUT1", "OUT0", "OUTq", "inclS", "PRI", "covS", "Solucion con nuevos cortes", "Solucion original", "n_terms_sol", "n_terms_ref", "n_terms_match", "match_pct", "match_label", "Estabilidad")
out <- tab[, intersect(wanted, names(tab)), drop = FALSE]
dt <- datatable(out, options = list(scrollX = TRUE, pageLength = 12))
nums <- intersect(c("incl_cut", "pri_cut", "inclS", "PRI", "covS", "match_pct"), names(out))
if (length(nums)) dt <- formatRound(dt, nums, digits = 3)
dt
})
output$report_solution_presence <- renderDT({
tab <- rv$solutions$presence$public_inter %||% data.frame()
keep <- intersect(c("Configuration", "Expression", "Raw_coverage", "Unique_coverage", "Consistency"), names(tab))
out <- tab[, keep, drop = FALSE]
if (ncol(out) > 0) names(out) <- c("Configuración", "Expresión", "Cobertura bruta", "Cobertura única", "Consistencia")[seq_len(ncol(out))]
dt <- datatable(out, options = list(scrollX = TRUE, paging = FALSE, searching = FALSE, info = FALSE, dom = "t"))
nums <- names(out)[vapply(out, is.numeric, logical(1))]
if (length(nums)) dt <- formatRound(dt, nums, digits = 3)
dt
})
output$report_solution_absence <- renderDT({
tab <- rv$solutions$absence$public_inter %||% data.frame()
keep <- intersect(c("Configuration", "Expression", "Raw_coverage", "Unique_coverage", "Consistency"), names(tab))
out <- tab[, keep, drop = FALSE]
if (ncol(out) > 0) names(out) <- c("Configuración", "Expresión", "Cobertura bruta", "Cobertura única", "Consistencia")[seq_len(ncol(out))]
dt <- datatable(out, options = list(scrollX = TRUE, paging = FALSE, searching = FALSE, info = FALSE, dom = "t"))
nums <- names(out)[vapply(out, is.numeric, logical(1))]
if (length(nums)) dt <- formatRound(dt, nums, digits = 3)
dt
})
output$report_solution_tables <- renderUI({
report_solution_matrix_ui(rv)
})
output$report_solution_all <- renderDT({
out <- report_solution_df(rv)
dt <- datatable(out, options = list(scrollX = TRUE, paging = FALSE, searching = FALSE, info = FALSE, dom = "t"))
nums <- names(out)[vapply(out, is.numeric, logical(1))]
if (length(nums)) dt <- formatRound(dt, nums, digits = 3)
dt
})
output$report_robustness_panel <- renderUI({
if (is.null(rv$robustness) || nrow(rv$robustness) == 0) {
return(div(class = "locked-box", "Robustez no ejecutada. Es opcional: el reporte de soluciones se puede revisar y exportar sin este paso."))
}
DTOutput("report_robustness")
})
output$report_robustness <- renderDT({
tab <- rv$robustness %||% data.frame()
wanted <- c("nombre", "incl_cut", "pri_cut", "n_cut", "OUT1", "OUT0", "OUTq", "inclS", "PRI", "covS", "Solucion con nuevos cortes", "Solucion original", "n_terms_sol", "n_terms_ref", "n_terms_match", "match_pct", "match_label", "Estabilidad")
out <- tab[, intersect(wanted, names(tab)), drop = FALSE]
dt <- datatable(out, options = list(scrollX = TRUE, paging = FALSE, searching = FALSE, info = FALSE, dom = "t"))
nums <- intersect(c("incl_cut", "pri_cut", "inclS", "PRI", "covS", "match_pct"), names(out))
if (length(nums)) dt <- formatRound(dt, nums, digits = 3)
dt
})
output$flower_presence_report <- renderPlot({
req(rv$solutions$presence, rv$calibrated)
plot_solution_flowers(rv$solutions$presence$inter_txt, rv$solutions$presence$pars_txt, unname(rv$model$internal_map[rv$model$conditions]), rv$calibrated$label_map, "P")
})
output$flower_absence_report <- renderPlot({
req(rv$solutions$absence, rv$calibrated)
plot_solution_flowers(rv$solutions$absence$inter_txt, rv$solutions$absence$pars_txt, unname(rv$model$internal_map[rv$model$conditions]), rv$calibrated$label_map, "A")
})
output$download_xlsx <- downloadHandler(
filename = function() "fsQCA_Studio_salida.xlsx",
content = function(file) write_results_workbook(file, rv)
)
output$download_rtf <- downloadHandler(
filename = function() "Material_Suplementario_fsQCA.rtf",
content = function(file) {
txt <- make_report_text(rv)
txt <- gsub("\\\\", "\\\\\\\\", txt)
txt <- gsub("\\{", "\\\\{", txt)
txt <- gsub("\\}", "\\\\}", txt)
rtf <- paste0("{\\rtf1\\ansi\\deff0\n", gsub("\n", "\\\\par\n", txt), "\n}")
writeLines(rtf, file, useBytes = TRUE)
}
)
output$download_visual_report <- downloadHandler(
filename = function() "Reporte_visual_fsQCA.html",
content = function(file) write_visual_report_html(file, rv)
)
output$download_r_script <- downloadHandler(
filename = function() "Sintaxis_modelo_fsQCA.R",
content = function(file) {
writeLines(make_reproduce_r(rv), file, useBytes = TRUE)
}
)
}
shinyApp(ui, server)