In sooyongl/ESS:
knitr::opts_chunk$set(echo = TRUE)
library(DT)
library(flexdashboard)
library(tidyverse)
library(shiny)
library(knitr)
library(kableExtra)
library(readxl)
library(foreach)
library(glue)
library(splines)
library(mgcv)
library(tidymv)
library(ggpubr)
# library(ESS)
# library(mapproj) # https://stackoverflow.com/questions/57927091/problem-deploying-shiny-app-using-github-package
source("source/spike_function.r")
source("source/simulation_function.r")
source("source/bootstrap_function.r")
data_list <- fs::dir_ls(file.path("data"))
Inputs {.sidebar}
# Empirical
radioButtons("empirical",
label = "Empricial or Simulated",
choices = c("empirical", "simulated"),
selected = NULL)
renderUI({
if(input$empirical == "empirical") {
radioButtons("files",
label = "File",
choices = data_list,
selected = data_list[1])
}
})
imprt_data <- eventReactive(input$files, {
file_path <- input$files
imprt_data <-
file_path %>%
excel_sheets() %>%
map(read_excel, path = file_path) %>%
set_names(., nm = c("setup", "panelist", "rating", "item_data", "examinee_data"))
return(imprt_data)
})
#
rating_data <- eventReactive(imprt_data(), {
rating_data <- imprt_data()[[3]]
rating_data <- rating_data %>%
mutate(ALD = case_when(ALD == "early" ~ 1, ALD == "mid" ~ 2, TRUE ~ 3))
rating_data
})
#
item_data <- eventReactive(imprt_data(), {
item_data <- imprt_data()[[4]] %>% rename("OOD" = "Order_of_Difficulty")
item_data
})
#
renderUI({
if(input$empirical == "empirical") {
radioButtons("pick_grade",
label = "Grades",
choices = 0
)
}
})
observeEvent(input$files, {
grades <- rating_data() %>% pull(GCA) %>% unique()
updateRadioButtons(
session,
inputId = "pick_grade",
label = NULL,
choices = grades,
selected = grades[1])
})
# Simulation
renderUI({
if(input$empirical == "simulated") {
numericInput(
inputId = "cor_value",
label = "Correlation bw Loc and ALD",
value = 0.6,
min = 0,
max = 1
)
}
})
renderUI({
if(input$empirical == "simulated") {
numericInput(
inputId = "nitem",
label = "Num of Items",
value = 200,
min = 30,
max = 1000,
step = 1
)
}
})
renderUI({
if(input$empirical == "simulated") {
radioButtons(
inputId = "dist",
label = "Distribution of Locations",
choices = c("Uniform", "Normal"),
selected = "Uniform")
}
})
renderUI({
if(input$empirical == "simulated") {
numericInput(
inputId = "dist_info1",
label = "Info of Dist 1 (min for unif;mean for norm)",
value = 100,
min = 1,
max = 1000,
step = 1
)}
})
renderUI({
if(input$empirical == "simulated") {
numericInput(
inputId = "dist_info2",
label = "Num of Dist 2 (max for unif;sd for norm)",
value = 300,
min = 50,
max = 1000,
step = 1
)}
})
# renderUI({
# if(input$empirical == "simulated") {
actionButton("button", "Import data")
# }
# })
new_data <- eventReactive(input$button, {
if(input$empirical == "empirical") {
pick_grade <- input$pick_grade
rating_data <- rating_data() %>% filter(GCA == pick_grade)
item_data <- item_data() %>% filter(GCA == pick_grade)
new_data <-
rating_data %>%
left_join(., item_data %>% select(Item_ID, OOD, Loc_RP50), by = c("Item_ID")) %>%
select(Item_ID, Loc_RP50, OOD, ALD) %>%
arrange(OOD)
} else {
dist <- ifelse(input$dist == "Normal", "rnorm", "runif")
new_data <- genFakeData(
fun = dist,
cor_value=input$cor_value,
nlevel=3,
n = input$nitem,
input$dist_info1,
input$dist_info2) %>%
mutate(Item_ID = row_number(), .before = Loc_RP50)
return(new_data)
}
return(new_data)
})
Change cut scores
numericInput(
inputId = "alpha",
label = "Alpha",
value = 1,
min = -5,
max = 5,
step = 0.1
)
sliderInput(
inputId ="cut_score2",
label = "Possible cut scores for Level 2",
min = 1,
max = 200,
value = 100
)
sliderInput(
inputId ="cut_score3",
label = "Possible cut scores for Level 3",
min = 1,
max = 200,
value = 100
)
observeEvent(new_data(), {
loc_range <- round(new_data()$Loc_RP50,0)
updateSliderInput(
session,
inputId ="cut_score2",
label = "Possible cut scores for Level 2",
min = min(loc_range),
max = max(loc_range),
value = median(loc_range)
)
updateSliderInput(
session,
inputId ="cut_score3",
label = "Possible cut scores for Level 3",
min = min(loc_range),
max = max(loc_range),
value = median(loc_range)
)
})
Plot font size
sliderInput(
inputId ="point_size",
label = "point_size",
min = 0.5,
max = 20,
value = 2
)
sliderInput(
inputId ="font_size",
label = "font_size",
min = 10,
max = 30,
value = 15
)
Descriptive
Column {.tabset}
histogram of location
renderPlot({
new_data <- new_data()
new_data %>%
ggplot() +
geom_histogram(aes(Loc_RP50), color="black", fill="white", binwidth=10) +
theme_bw()
})
Column {.tabset}
by each level
renderPlot({
new_data <- new_data()
new_data %>%
ggplot() +
geom_histogram(aes(Loc_RP50), color="black", fill="white", binwidth=10) +
facet_grid(. ~ ALD) +
theme_bw()
})
Search Cuts
incon_lv2 <- reactive({
new_data <- new_data()
cut_lv2 <- input$cut_score2
evalInconsistency(new_data, d_alpha = input$alpha, 2, cut_lv2)
})
incon_lv3 <- reactive({
new_data <- new_data()
cut_lv3 <- input$cut_score3
evalInconsistency(new_data, d_alpha = input$alpha, 3, cut_lv3)
})
Column {.tabset}
level 2 cuts
renderPlot({
incon_lv2 <- incon_lv2()
font_size <- input$font_size
spikePlot(incon_lv2, xaxix_con = F, font_size = font_size, point_size = input$point_size)
})
Column {.tabset}
level 3 cuts
renderPlot({
incon_lv3 <- incon_lv3()
font_size <- input$font_size
spikePlot(incon_lv3, xaxix_con = F, font_size = font_size, point_size = input$point_size)
})
Item location distribution
Column {.tabset}
level 2 cuts
# renderPlotly({
renderPlot({
incon_lv2 <- incon_lv2()
font_size <- input$font_size
# ggplotly(
spikePlot(incon_lv2, xaxix_con = T, font_size = font_size, point_size = input$point_size)
# )
})
Column {.tabset}
level 3 cuts
renderPlot({
incon_lv3 <- incon_lv3()
font_size <- input$font_size
spikePlot(incon_lv3, xaxix_con = T, font_size = font_size, point_size = input$point_size)
})
Run ESS
actionButton("button2", "Run ESS")
est_data <- eventReactive(input$button2, {
new_data <- new_data()
cut_candi <- new_data$Loc_RP50
cut_info_lv2 <- map_df(cut_candi, ~ evalInconsistency(new_data, input$alpha, 2, .x)$cut_info)
cut_info_lv3 <- map_df(cut_candi, ~ evalInconsistency(new_data, input$alpha, 3, .x)$cut_info)
est_data <- list(
res = cut_info_lv2 %>%
rename("Loc_RP50" = "cut_score",
"L2" = "counts",
"L2_W" = "weights") %>%
bind_cols(., cut_info_lv3 %>%
select(counts, weights) %>%
rename("L3" = "counts",
"L3_W" = "weights")),
selected_CP = list(
WESS = c(which.min(cut_info_lv2$weights),which.min(cut_info_lv3$weights)),
CESS = c(which.min(cut_info_lv2$counts),which.min(cut_info_lv3$counts))
)
)
return(est_data)
})
Column {.tabset}
WESS
renderPlot({
WESS = T
est_data <- est_data()
cut_scores <- est_data$selected_CP$WESS
est_data <- est_data$res
cut_weight <- est_data$Loc_RP50[cut_scores]
x_axis <- round(est_data$Loc_RP50,0)
r_sample <- cut_scores
x_breaks <- round(x_axis[r_sample],1)
annote <- paste0("Cut item = ",paste(cut_scores, collapse = ", "),"\n",
"Cut location = ", paste(round(cut_weight,1), collapse = ", "))
if(WESS){
est_data <- est_data %>%
select(starts_with("Loc_"), ends_with("_W")) %>%
gather("Levels","weights", -starts_with("Loc_"))
names(est_data)[1] <- c("Location")
x_var <- "Location"
} else {
est_data <- est_data %>% select(starts_with("OOD"), matches("^L[0-9]$"))
x_axis <- 1:dim(est_data)[1]
est_data <- est_data %>% gather("Levels","counts", -starts_with("OOD"))
names(est_data)[1] <- c("OOD")
x_var <- "OOD"
r_sample <- unique(c(1,cut_scores, length(x_axis)))
x_breaks <- cut_scores
cut_weight <- cut_scores
}
x_var <- "Location"
y_axis <- est_data[,3]
p1 <- ggplot(est_data, aes_string(x_var, names(est_data)[3], colour = "Levels") ) +
geom_point(aes(shape = Levels), alpha = 0.5, size = input$point_size) +
geom_vline(xintercept = cut_weight, colour = "blue", size = 1.5, linetype = "dotted", alpha = 0.5) +
scale_x_continuous(breaks = x_breaks) +
annotate("text", x = -Inf, y = Inf, hjust = -1, vjust = 1,
label = annote) +
theme_bw(base_size = input$font_size)
# if(fit){
# p1<- p1 + stat_smooth(method = lm, formula = y ~ x + I(x^2), alpha = 0.4)
# }
return(p1)
})
Column {.tabset}
CESS
renderPlot({
WESS = F
est_data <- est_data()
cut_scores <- est_data$selected_CP$CESS
est_data <- est_data$res %>% mutate(OOD = row_number())
cut_weight <- est_data$Loc_RP50[cut_scores]
x_axis <- round(est_data$Loc_RP50,0)
r_sample <- cut_scores
x_breaks <- round(x_axis[r_sample],1)
annote <- paste0("Cut item = ",paste(cut_scores, collapse = ", "),"\n",
"Cut location = ", paste(round(cut_weight,1), collapse = ", "))
# c(min(x_axis),cut_scores,max(x_axis))
if(WESS){
est_data <- est_data %>%
select(starts_with("Loc_"), ends_with("_W")) %>%
gather("Levels","weights", -starts_with("Loc_"))
names(est_data)[1] <- c("Location")
x_var <- "Location"
} else {
# .data <- .data %>% select(Loc_RP67, L2, L3)
est_data <- est_data %>% select(starts_with("Loc_"), matches("^L[0-9]$"))
x_axis <- 1:dim(est_data)[1]
est_data <- est_data %>% gather("Levels","counts", -starts_with("Loc_"))
names(est_data)[1] <- c("Location")
# x_var <- "OOD"
x_var <- "Location"
# r_sample <- unique(c(1,cut_scores, length(x_axis)))
# x_breaks <- r_sample
# x_breaks <- cut_scores
# cut_weight <- cut_scores
}
# x_var <- "Location"
y_axis <- est_data[,3]
p1 <- ggplot(est_data, aes_string(x_var, names(est_data)[3], colour = "Levels") ) +
geom_point(aes(shape = Levels), alpha = 0.5, size = input$point_size) +
geom_vline(xintercept = cut_weight, colour = "blue", size = 1.5, linetype = "dotted", alpha = 0.5) +
scale_x_continuous(breaks = x_breaks) +
annotate("text", x = -Inf, y = Inf, hjust = -1, vjust = 1, label = annote) +
theme_bw(base_size = input$font_size)
# if(fit){
# p1<- p1 + stat_smooth(method = lm, formula = y ~ x + I(x^2), alpha = 0.4)
# }
return(p1)
})
Splines regession
numericInput(
inputId = "spline",
label = "Splines",
value = 3,
min = 1,
max = 1000
)
Column {.tabset}
Estimated data
renderDT({
est_data <- est_data()$res %>% mutate(OOD = row_number())
est_data
})
Level 2 - count
renderPlot({
est_data <- est_data()$res %>% mutate(OOD = row_number())
# input<-list()
# input$spline <- 10
inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})")
ggplot(est_data, aes(Loc_RP50, L2) ) +
geom_point() +
stat_smooth(method = 'gam',
# method.args = list(family = "binomial"),
formula = formula(inp_formula)) +
theme_bw()
})
Level 2 - weight
renderPlot({
est_data <- est_data()$res %>% mutate(OOD = row_number())
inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})")
# find minimum value and find x value <- this is the minimizer (cut score)
ggplot(est_data, aes(Loc_RP50, L2_W) ) +
geom_point() +
stat_smooth(method = 'gam',
# method.args = list(family = "binomial"),
formula = formula(inp_formula)) +
theme_bw()
})
Column {.tabset}
Level 3 - count
renderPlot({
est_data <- est_data()$res %>% mutate(OOD = row_number())
inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})")
ggplot(est_data, aes(Loc_RP50, L3) ) +
geom_point() +
stat_smooth(method = 'gam',
# method.args = list(family = "binomial"),
formula = formula(inp_formula)) +
theme_bw()
})
Level 3 - weight
renderPlot({
est_data <- est_data()$res %>% mutate(OOD = row_number())
inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})")
ggplot(est_data, aes(Loc_RP50, L3_W) ) +
geom_point() +
stat_smooth(method = 'gam',
# method.args = list(family = "binomial"),
formula =formula(inp_formula)) +
theme_bw()
})
Bootstrapping (with generalized additive model)
fluidRow(
column(3,
actionButton("refresh", "Refresh")
),
column(3,
numericInput(
inputId = "frac",
label = "Rate",
value = 0.75,
min = 0.1,
max = 1
)
)
)
# numericInput(
# inputId = "frac",
# label = "Rate",
# value = 0.75,
# min = 0.1,
# max = 1,
# inline = T
# )
boot_data <- reactive({
est_data <- new_data()
est_data
})
cut_lv2 <- reactive({estCutScore(boot_data(), cut_level = 2)})
cut_lv3 <- reactive({estCutScore(boot_data(), cut_level = 3)})
cut_lv2_frac <- eventReactive(input$refresh, {
use.data_frac <-
boot_data() %>%
sample_frac(size = 1, replace = T) %>%
arrange(Item_ID)
cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 2)
cut_lv2_frac
})
cut_lv2_frac <- eventReactive(input$refresh, {
use.data_frac <-
boot_data() %>%
sample_frac(size = input$frac) %>%
arrange(Item_ID)
cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 2)
cut_lv2_frac
})
lv2_cut_res <- eventReactive(input$refresh, {
cut_lv2 <- cut_lv2()
use.data_cut_res <- boot_fun(cut_lv2$cut_info, b_prop = input$frac)
use.data_cut_res <- append(list(cut_info = use.data_cut_res$cut_info), use.data_cut_res)
use.data_cut_res
})
cut_lv3_frac <- eventReactive(input$refresh, {
use.data_frac <-
boot_data() %>%
sample_frac(size = 1, replace = T) %>%
arrange(Item_ID)
cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 3)
cut_lv2_frac
})
cut_lv3_frac <- eventReactive(input$refresh, {
use.data_frac <-
boot_data() %>%
sample_frac(size = input$frac) %>%
arrange(Item_ID)
cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 3)
cut_lv2_frac
})
lv3_cut_res <- eventReactive(input$refresh, {
cut_lv2 <- cut_lv3()
use.data_cut_res <- boot_fun(cut_lv2$cut_info, b_prop = input$frac)
use.data_cut_res <- append(list(cut_info = use.data_cut_res$cut_info), use.data_cut_res)
use.data_cut_res
})
Column {.tabset}
Level 2 - count
renderPlot({
use.data <- boot_data()
cut_lv2 <- cut_lv2()
ori_p <- cutPlot(cut_lv2, counts = T)
# Replacement
replace_p <- cutPlot(cut_lv2_frac(), counts = T)
# Fraction without replacement
frac_p <- cutPlot(cut_lv2_frac(), counts = T)
# sample from cut result
cr_p <- cutPlot(lv2_cut_res(), counts = T)
ggarrange(ori_p, replace_p, frac_p, cr_p,
labels = c("original","replacement","fraction","from_result"))
})
Level 2 - weight
renderPlot({
use.data <- boot_data()
cut_lv2 <- cut_lv2()
ori_p <- cutPlot(cut_lv2, counts = F)
# Replacement
replace_p <- cutPlot(cut_lv2_frac(), counts = F)
# Fraction without replacement
frac_p <- cutPlot(cut_lv2_frac(), counts = F)
# sample from cut result
cr_p <- cutPlot(lv2_cut_res(), counts = F)
ggarrange(ori_p, replace_p, frac_p, cr_p,
labels = c("original","replacement","fraction","from_result"))
})
Column {.tabset}
Level 3 - count
renderPlot({
use.data <- boot_data()
cut_lv3 <- cut_lv3()
ori_p <- cutPlot(cut_lv3, counts = T)
# Replacement
replace_p <- cutPlot(cut_lv3_frac(), counts = T)
# Fraction without replacement
frac_p <- cutPlot(cut_lv3_frac(), counts = T)
# sample from cut result
cr_p <- cutPlot(lv3_cut_res(), counts = T)
ggarrange(ori_p, replace_p, frac_p, cr_p,
labels = c("original","replacement","fraction","from_result"))
})
Level 3 - weight
renderPlot({
use.data <- boot_data()
cut_lv3 <- cut_lv3()
ori_p <- cutPlot(cut_lv3, counts = F)
# Replacement
replace_p <- cutPlot(cut_lv3_frac(), counts = F)
# Fraction without replacement
frac_p <- cutPlot(cut_lv3_frac(), counts = F)
# sample from cut result
cr_p <- cutPlot(lv3_cut_res(), counts = F)
ggarrange(ori_p, replace_p, frac_p, cr_p,
labels = c("original","replacement","fraction","from_result"))
})
Cut scores across alpha levels
actionButton("button3", "Run across alpha")
d1 <- eventReactive(input$button3,{
alpha_level <- seq(0, 1, by = 0.1)
d1 <- lapply(1:length(alpha_level), function(i) {
# i <- 1
cut_candi <- new_data()$Loc_RP50
cut_info_lv2 <- map_df(cut_candi, ~ evalInconsistency(new_data(), d_alpha = alpha_level[i], 2, .x)$cut_info)
cut_info_lv3 <- map_df(cut_candi, ~ evalInconsistency(new_data(), d_alpha = alpha_level[i], 3, .x)$cut_info)
res = cut_info_lv2 %>%
rename("Loc_RP50" = "cut_score",
"L2" = "counts",
"L2_W" = "weights") %>%
bind_cols(., cut_info_lv3 %>%
select(counts, weights) %>%
rename("L3" = "counts",
"L3_W" = "weights"))
WESS = c(which.min(cut_info_lv2$weights),which.min(cut_info_lv3$weights))
CESS = c(which.min(cut_info_lv2$counts),which.min(cut_info_lv3$counts))
WESS_cuts <- res$Loc_RP50[WESS]
CESS_cuts <- res$Loc_RP50[CESS]
c(alpha_level[i], WESS_cuts, CESS_cuts, WESS, CESS)
})
d1 <-
do.call('rbind',d1) %>%
data.frame() %>%
setNames(c("D_alpha","Lv2_W","Lv3_W","Lv2","Lv3","Lv2_cut_weight","Lv3_cut_weight","Lv2_cut_count","Lv3_cut_count")) %>%
mutate_all(round, 3)
return(d1)
})
Column {.tabset}
level 2 cuts
renderPlot({
d1 <- d1()
d1 %>%
ggplot() +
geom_point(aes(x = D_alpha, y = Lv2_W)) +
geom_line(aes(x = D_alpha, y = Lv2), colour = "red", linetype = "dashed") +
# geom_line(aes(x = D_alpha, y = Lv2), colour = "blue", linetype = "dashed") +
geom_col(aes(x = D_alpha, y = Lv2_W), width = .001, alpha = 0.7) +
geom_text(aes(x = D_alpha, y = Lv2_W, label = Lv2_cut_weight),
# hjust=-0.5,
vjust=-0.5,
size = 5) +
scale_x_reverse(breaks = seq(0,1, 0.1)) +
lims(y = c(min(d1$Lv2_W)-sd(d1$Lv2_W), max(d1$Lv2_W)+sd(d1$Lv2_W))) +
labs(caption = "Numbers above points indicate the cut OOD; Red dashed line indicates the cut score using ESS-count") +
theme_bw(base_size = input$font_size) +
theme(plot.caption=element_text(size=18, hjust=0, face="italic", color="black"))
})
Column {.tabset}
level 3 cuts
renderPlot({
d1 <- d1()
d1 %>%
ggplot() +
geom_point(aes(x = D_alpha, y = Lv3_W)) +
geom_col(aes(x = D_alpha, y = Lv3_W), width = .001, alpha = 0.7) +
geom_line(aes(x = D_alpha, y = Lv3), colour = "red", linetype = "dashed") +
# geom_line(aes(x = D_alpha, y = Lv3), colour = "blue", linetype = "dashed") +
geom_text(aes(x = D_alpha, y = Lv3_W, label = Lv3_cut_weight),
# hjust=-0.5,
vjust=-0.5,
size = 5) +
scale_x_reverse(breaks = seq(0,1, 0.1)) +
lims(y = c(min(d1$Lv3_W)-sd(d1$Lv3_W), max(d1$Lv3_W)+sd(d1$Lv3_W))) +
labs(caption = "Numbers above points indicate the cut OOD; Red dashed line indicates the cut score using ESS-count") +
theme_bw(base_size = input$font_size) +
theme(plot.caption=element_text(size=18, hjust=0, face="italic", color="black"))
})
sooyongl/ESS documentation built on Dec. 23, 2021, 4:22 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
knitr::opts_chunk$set(echo = TRUE) library(DT) library(flexdashboard) library(tidyverse) library(shiny) library(knitr) library(kableExtra) library(readxl) library(foreach) library(glue) library(splines) library(mgcv) library(tidymv) library(ggpubr) # library(ESS) # library(mapproj) # https://stackoverflow.com/questions/57927091/problem-deploying-shiny-app-using-github-package source("source/spike_function.r") source("source/simulation_function.r") source("source/bootstrap_function.r") data_list <- fs::dir_ls(file.path("data"))
Inputs {.sidebar}
# Empirical radioButtons("empirical", label = "Empricial or Simulated", choices = c("empirical", "simulated"), selected = NULL) renderUI({ if(input$empirical == "empirical") { radioButtons("files", label = "File", choices = data_list, selected = data_list[1]) } }) imprt_data <- eventReactive(input$files, { file_path <- input$files imprt_data <- file_path %>% excel_sheets() %>% map(read_excel, path = file_path) %>% set_names(., nm = c("setup", "panelist", "rating", "item_data", "examinee_data")) return(imprt_data) }) # rating_data <- eventReactive(imprt_data(), { rating_data <- imprt_data()[[3]] rating_data <- rating_data %>% mutate(ALD = case_when(ALD == "early" ~ 1, ALD == "mid" ~ 2, TRUE ~ 3)) rating_data }) # item_data <- eventReactive(imprt_data(), { item_data <- imprt_data()[[4]] %>% rename("OOD" = "Order_of_Difficulty") item_data }) # renderUI({ if(input$empirical == "empirical") { radioButtons("pick_grade", label = "Grades", choices = 0 ) } }) observeEvent(input$files, { grades <- rating_data() %>% pull(GCA) %>% unique() updateRadioButtons( session, inputId = "pick_grade", label = NULL, choices = grades, selected = grades[1]) }) # Simulation renderUI({ if(input$empirical == "simulated") { numericInput( inputId = "cor_value", label = "Correlation bw Loc and ALD", value = 0.6, min = 0, max = 1 ) } }) renderUI({ if(input$empirical == "simulated") { numericInput( inputId = "nitem", label = "Num of Items", value = 200, min = 30, max = 1000, step = 1 ) } }) renderUI({ if(input$empirical == "simulated") { radioButtons( inputId = "dist", label = "Distribution of Locations", choices = c("Uniform", "Normal"), selected = "Uniform") } }) renderUI({ if(input$empirical == "simulated") { numericInput( inputId = "dist_info1", label = "Info of Dist 1 (min for unif;mean for norm)", value = 100, min = 1, max = 1000, step = 1 )} }) renderUI({ if(input$empirical == "simulated") { numericInput( inputId = "dist_info2", label = "Num of Dist 2 (max for unif;sd for norm)", value = 300, min = 50, max = 1000, step = 1 )} }) # renderUI({ # if(input$empirical == "simulated") { actionButton("button", "Import data") # } # })
new_data <- eventReactive(input$button, { if(input$empirical == "empirical") { pick_grade <- input$pick_grade rating_data <- rating_data() %>% filter(GCA == pick_grade) item_data <- item_data() %>% filter(GCA == pick_grade) new_data <- rating_data %>% left_join(., item_data %>% select(Item_ID, OOD, Loc_RP50), by = c("Item_ID")) %>% select(Item_ID, Loc_RP50, OOD, ALD) %>% arrange(OOD) } else { dist <- ifelse(input$dist == "Normal", "rnorm", "runif") new_data <- genFakeData( fun = dist, cor_value=input$cor_value, nlevel=3, n = input$nitem, input$dist_info1, input$dist_info2) %>% mutate(Item_ID = row_number(), .before = Loc_RP50) return(new_data) } return(new_data) })
Change cut scores
numericInput( inputId = "alpha", label = "Alpha", value = 1, min = -5, max = 5, step = 0.1 ) sliderInput( inputId ="cut_score2", label = "Possible cut scores for Level 2", min = 1, max = 200, value = 100 ) sliderInput( inputId ="cut_score3", label = "Possible cut scores for Level 3", min = 1, max = 200, value = 100 ) observeEvent(new_data(), { loc_range <- round(new_data()$Loc_RP50,0) updateSliderInput( session, inputId ="cut_score2", label = "Possible cut scores for Level 2", min = min(loc_range), max = max(loc_range), value = median(loc_range) ) updateSliderInput( session, inputId ="cut_score3", label = "Possible cut scores for Level 3", min = min(loc_range), max = max(loc_range), value = median(loc_range) ) })
Plot font size
sliderInput( inputId ="point_size", label = "point_size", min = 0.5, max = 20, value = 2 ) sliderInput( inputId ="font_size", label = "font_size", min = 10, max = 30, value = 15 )
Descriptive
Column {.tabset}
histogram of location
renderPlot({ new_data <- new_data() new_data %>% ggplot() + geom_histogram(aes(Loc_RP50), color="black", fill="white", binwidth=10) + theme_bw() })
Column {.tabset}
by each level
renderPlot({ new_data <- new_data() new_data %>% ggplot() + geom_histogram(aes(Loc_RP50), color="black", fill="white", binwidth=10) + facet_grid(. ~ ALD) + theme_bw() })
Search Cuts
incon_lv2 <- reactive({ new_data <- new_data() cut_lv2 <- input$cut_score2 evalInconsistency(new_data, d_alpha = input$alpha, 2, cut_lv2) }) incon_lv3 <- reactive({ new_data <- new_data() cut_lv3 <- input$cut_score3 evalInconsistency(new_data, d_alpha = input$alpha, 3, cut_lv3) })
Column {.tabset}
level 2 cuts
renderPlot({ incon_lv2 <- incon_lv2() font_size <- input$font_size spikePlot(incon_lv2, xaxix_con = F, font_size = font_size, point_size = input$point_size) })
Column {.tabset}
level 3 cuts
renderPlot({ incon_lv3 <- incon_lv3() font_size <- input$font_size spikePlot(incon_lv3, xaxix_con = F, font_size = font_size, point_size = input$point_size) })
Item location distribution
Column {.tabset}
level 2 cuts
# renderPlotly({ renderPlot({ incon_lv2 <- incon_lv2() font_size <- input$font_size # ggplotly( spikePlot(incon_lv2, xaxix_con = T, font_size = font_size, point_size = input$point_size) # ) })
Column {.tabset}
level 3 cuts
renderPlot({ incon_lv3 <- incon_lv3() font_size <- input$font_size spikePlot(incon_lv3, xaxix_con = T, font_size = font_size, point_size = input$point_size) })
Run ESS
actionButton("button2", "Run ESS")
est_data <- eventReactive(input$button2, { new_data <- new_data() cut_candi <- new_data$Loc_RP50 cut_info_lv2 <- map_df(cut_candi, ~ evalInconsistency(new_data, input$alpha, 2, .x)$cut_info) cut_info_lv3 <- map_df(cut_candi, ~ evalInconsistency(new_data, input$alpha, 3, .x)$cut_info) est_data <- list( res = cut_info_lv2 %>% rename("Loc_RP50" = "cut_score", "L2" = "counts", "L2_W" = "weights") %>% bind_cols(., cut_info_lv3 %>% select(counts, weights) %>% rename("L3" = "counts", "L3_W" = "weights")), selected_CP = list( WESS = c(which.min(cut_info_lv2$weights),which.min(cut_info_lv3$weights)), CESS = c(which.min(cut_info_lv2$counts),which.min(cut_info_lv3$counts)) ) ) return(est_data) })
Column {.tabset}
WESS
renderPlot({ WESS = T est_data <- est_data() cut_scores <- est_data$selected_CP$WESS est_data <- est_data$res cut_weight <- est_data$Loc_RP50[cut_scores] x_axis <- round(est_data$Loc_RP50,0) r_sample <- cut_scores x_breaks <- round(x_axis[r_sample],1) annote <- paste0("Cut item = ",paste(cut_scores, collapse = ", "),"\n", "Cut location = ", paste(round(cut_weight,1), collapse = ", ")) if(WESS){ est_data <- est_data %>% select(starts_with("Loc_"), ends_with("_W")) %>% gather("Levels","weights", -starts_with("Loc_")) names(est_data)[1] <- c("Location") x_var <- "Location" } else { est_data <- est_data %>% select(starts_with("OOD"), matches("^L[0-9]$")) x_axis <- 1:dim(est_data)[1] est_data <- est_data %>% gather("Levels","counts", -starts_with("OOD")) names(est_data)[1] <- c("OOD") x_var <- "OOD" r_sample <- unique(c(1,cut_scores, length(x_axis))) x_breaks <- cut_scores cut_weight <- cut_scores } x_var <- "Location" y_axis <- est_data[,3] p1 <- ggplot(est_data, aes_string(x_var, names(est_data)[3], colour = "Levels") ) + geom_point(aes(shape = Levels), alpha = 0.5, size = input$point_size) + geom_vline(xintercept = cut_weight, colour = "blue", size = 1.5, linetype = "dotted", alpha = 0.5) + scale_x_continuous(breaks = x_breaks) + annotate("text", x = -Inf, y = Inf, hjust = -1, vjust = 1, label = annote) + theme_bw(base_size = input$font_size) # if(fit){ # p1<- p1 + stat_smooth(method = lm, formula = y ~ x + I(x^2), alpha = 0.4) # } return(p1) })
Column {.tabset}
CESS
renderPlot({ WESS = F est_data <- est_data() cut_scores <- est_data$selected_CP$CESS est_data <- est_data$res %>% mutate(OOD = row_number()) cut_weight <- est_data$Loc_RP50[cut_scores] x_axis <- round(est_data$Loc_RP50,0) r_sample <- cut_scores x_breaks <- round(x_axis[r_sample],1) annote <- paste0("Cut item = ",paste(cut_scores, collapse = ", "),"\n", "Cut location = ", paste(round(cut_weight,1), collapse = ", ")) # c(min(x_axis),cut_scores,max(x_axis)) if(WESS){ est_data <- est_data %>% select(starts_with("Loc_"), ends_with("_W")) %>% gather("Levels","weights", -starts_with("Loc_")) names(est_data)[1] <- c("Location") x_var <- "Location" } else { # .data <- .data %>% select(Loc_RP67, L2, L3) est_data <- est_data %>% select(starts_with("Loc_"), matches("^L[0-9]$")) x_axis <- 1:dim(est_data)[1] est_data <- est_data %>% gather("Levels","counts", -starts_with("Loc_")) names(est_data)[1] <- c("Location") # x_var <- "OOD" x_var <- "Location" # r_sample <- unique(c(1,cut_scores, length(x_axis))) # x_breaks <- r_sample # x_breaks <- cut_scores # cut_weight <- cut_scores } # x_var <- "Location" y_axis <- est_data[,3] p1 <- ggplot(est_data, aes_string(x_var, names(est_data)[3], colour = "Levels") ) + geom_point(aes(shape = Levels), alpha = 0.5, size = input$point_size) + geom_vline(xintercept = cut_weight, colour = "blue", size = 1.5, linetype = "dotted", alpha = 0.5) + scale_x_continuous(breaks = x_breaks) + annotate("text", x = -Inf, y = Inf, hjust = -1, vjust = 1, label = annote) + theme_bw(base_size = input$font_size) # if(fit){ # p1<- p1 + stat_smooth(method = lm, formula = y ~ x + I(x^2), alpha = 0.4) # } return(p1) })
Splines regession
numericInput( inputId = "spline", label = "Splines", value = 3, min = 1, max = 1000 )
Column {.tabset}
Estimated data
renderDT({ est_data <- est_data()$res %>% mutate(OOD = row_number()) est_data })
Level 2 - count
renderPlot({ est_data <- est_data()$res %>% mutate(OOD = row_number()) # input<-list() # input$spline <- 10 inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})") ggplot(est_data, aes(Loc_RP50, L2) ) + geom_point() + stat_smooth(method = 'gam', # method.args = list(family = "binomial"), formula = formula(inp_formula)) + theme_bw() })
Level 2 - weight
renderPlot({ est_data <- est_data()$res %>% mutate(OOD = row_number()) inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})") # find minimum value and find x value <- this is the minimizer (cut score) ggplot(est_data, aes(Loc_RP50, L2_W) ) + geom_point() + stat_smooth(method = 'gam', # method.args = list(family = "binomial"), formula = formula(inp_formula)) + theme_bw() })
Column {.tabset}
Level 3 - count
renderPlot({ est_data <- est_data()$res %>% mutate(OOD = row_number()) inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})") ggplot(est_data, aes(Loc_RP50, L3) ) + geom_point() + stat_smooth(method = 'gam', # method.args = list(family = "binomial"), formula = formula(inp_formula)) + theme_bw() })
Level 3 - weight
renderPlot({ est_data <- est_data()$res %>% mutate(OOD = row_number()) inp_formula <- glue::glue("y ~ splines::ns(x, {input$spline})") ggplot(est_data, aes(Loc_RP50, L3_W) ) + geom_point() + stat_smooth(method = 'gam', # method.args = list(family = "binomial"), formula =formula(inp_formula)) + theme_bw() })
Bootstrapping (with generalized additive model)
fluidRow( column(3, actionButton("refresh", "Refresh") ), column(3, numericInput( inputId = "frac", label = "Rate", value = 0.75, min = 0.1, max = 1 ) ) ) # numericInput( # inputId = "frac", # label = "Rate", # value = 0.75, # min = 0.1, # max = 1, # inline = T # )
boot_data <- reactive({ est_data <- new_data() est_data }) cut_lv2 <- reactive({estCutScore(boot_data(), cut_level = 2)}) cut_lv3 <- reactive({estCutScore(boot_data(), cut_level = 3)})
cut_lv2_frac <- eventReactive(input$refresh, { use.data_frac <- boot_data() %>% sample_frac(size = 1, replace = T) %>% arrange(Item_ID) cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 2) cut_lv2_frac }) cut_lv2_frac <- eventReactive(input$refresh, { use.data_frac <- boot_data() %>% sample_frac(size = input$frac) %>% arrange(Item_ID) cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 2) cut_lv2_frac }) lv2_cut_res <- eventReactive(input$refresh, { cut_lv2 <- cut_lv2() use.data_cut_res <- boot_fun(cut_lv2$cut_info, b_prop = input$frac) use.data_cut_res <- append(list(cut_info = use.data_cut_res$cut_info), use.data_cut_res) use.data_cut_res })
cut_lv3_frac <- eventReactive(input$refresh, { use.data_frac <- boot_data() %>% sample_frac(size = 1, replace = T) %>% arrange(Item_ID) cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 3) cut_lv2_frac }) cut_lv3_frac <- eventReactive(input$refresh, { use.data_frac <- boot_data() %>% sample_frac(size = input$frac) %>% arrange(Item_ID) cut_lv2_frac <- estCutScore(use.data_frac, cut_level = 3) cut_lv2_frac }) lv3_cut_res <- eventReactive(input$refresh, { cut_lv2 <- cut_lv3() use.data_cut_res <- boot_fun(cut_lv2$cut_info, b_prop = input$frac) use.data_cut_res <- append(list(cut_info = use.data_cut_res$cut_info), use.data_cut_res) use.data_cut_res })
Column {.tabset}
Level 2 - count
renderPlot({ use.data <- boot_data() cut_lv2 <- cut_lv2() ori_p <- cutPlot(cut_lv2, counts = T) # Replacement replace_p <- cutPlot(cut_lv2_frac(), counts = T) # Fraction without replacement frac_p <- cutPlot(cut_lv2_frac(), counts = T) # sample from cut result cr_p <- cutPlot(lv2_cut_res(), counts = T) ggarrange(ori_p, replace_p, frac_p, cr_p, labels = c("original","replacement","fraction","from_result")) })
Level 2 - weight
renderPlot({ use.data <- boot_data() cut_lv2 <- cut_lv2() ori_p <- cutPlot(cut_lv2, counts = F) # Replacement replace_p <- cutPlot(cut_lv2_frac(), counts = F) # Fraction without replacement frac_p <- cutPlot(cut_lv2_frac(), counts = F) # sample from cut result cr_p <- cutPlot(lv2_cut_res(), counts = F) ggarrange(ori_p, replace_p, frac_p, cr_p, labels = c("original","replacement","fraction","from_result")) })
Column {.tabset}
Level 3 - count
renderPlot({ use.data <- boot_data() cut_lv3 <- cut_lv3() ori_p <- cutPlot(cut_lv3, counts = T) # Replacement replace_p <- cutPlot(cut_lv3_frac(), counts = T) # Fraction without replacement frac_p <- cutPlot(cut_lv3_frac(), counts = T) # sample from cut result cr_p <- cutPlot(lv3_cut_res(), counts = T) ggarrange(ori_p, replace_p, frac_p, cr_p, labels = c("original","replacement","fraction","from_result")) })
Level 3 - weight
renderPlot({ use.data <- boot_data() cut_lv3 <- cut_lv3() ori_p <- cutPlot(cut_lv3, counts = F) # Replacement replace_p <- cutPlot(cut_lv3_frac(), counts = F) # Fraction without replacement frac_p <- cutPlot(cut_lv3_frac(), counts = F) # sample from cut result cr_p <- cutPlot(lv3_cut_res(), counts = F) ggarrange(ori_p, replace_p, frac_p, cr_p, labels = c("original","replacement","fraction","from_result")) })
Cut scores across alpha levels
actionButton("button3", "Run across alpha")
d1 <- eventReactive(input$button3,{ alpha_level <- seq(0, 1, by = 0.1) d1 <- lapply(1:length(alpha_level), function(i) { # i <- 1 cut_candi <- new_data()$Loc_RP50 cut_info_lv2 <- map_df(cut_candi, ~ evalInconsistency(new_data(), d_alpha = alpha_level[i], 2, .x)$cut_info) cut_info_lv3 <- map_df(cut_candi, ~ evalInconsistency(new_data(), d_alpha = alpha_level[i], 3, .x)$cut_info) res = cut_info_lv2 %>% rename("Loc_RP50" = "cut_score", "L2" = "counts", "L2_W" = "weights") %>% bind_cols(., cut_info_lv3 %>% select(counts, weights) %>% rename("L3" = "counts", "L3_W" = "weights")) WESS = c(which.min(cut_info_lv2$weights),which.min(cut_info_lv3$weights)) CESS = c(which.min(cut_info_lv2$counts),which.min(cut_info_lv3$counts)) WESS_cuts <- res$Loc_RP50[WESS] CESS_cuts <- res$Loc_RP50[CESS] c(alpha_level[i], WESS_cuts, CESS_cuts, WESS, CESS) }) d1 <- do.call('rbind',d1) %>% data.frame() %>% setNames(c("D_alpha","Lv2_W","Lv3_W","Lv2","Lv3","Lv2_cut_weight","Lv3_cut_weight","Lv2_cut_count","Lv3_cut_count")) %>% mutate_all(round, 3) return(d1) })
Column {.tabset}
level 2 cuts
renderPlot({ d1 <- d1() d1 %>% ggplot() + geom_point(aes(x = D_alpha, y = Lv2_W)) + geom_line(aes(x = D_alpha, y = Lv2), colour = "red", linetype = "dashed") + # geom_line(aes(x = D_alpha, y = Lv2), colour = "blue", linetype = "dashed") + geom_col(aes(x = D_alpha, y = Lv2_W), width = .001, alpha = 0.7) + geom_text(aes(x = D_alpha, y = Lv2_W, label = Lv2_cut_weight), # hjust=-0.5, vjust=-0.5, size = 5) + scale_x_reverse(breaks = seq(0,1, 0.1)) + lims(y = c(min(d1$Lv2_W)-sd(d1$Lv2_W), max(d1$Lv2_W)+sd(d1$Lv2_W))) + labs(caption = "Numbers above points indicate the cut OOD; Red dashed line indicates the cut score using ESS-count") + theme_bw(base_size = input$font_size) + theme(plot.caption=element_text(size=18, hjust=0, face="italic", color="black")) })
Column {.tabset}
level 3 cuts
renderPlot({ d1 <- d1() d1 %>% ggplot() + geom_point(aes(x = D_alpha, y = Lv3_W)) + geom_col(aes(x = D_alpha, y = Lv3_W), width = .001, alpha = 0.7) + geom_line(aes(x = D_alpha, y = Lv3), colour = "red", linetype = "dashed") + # geom_line(aes(x = D_alpha, y = Lv3), colour = "blue", linetype = "dashed") + geom_text(aes(x = D_alpha, y = Lv3_W, label = Lv3_cut_weight), # hjust=-0.5, vjust=-0.5, size = 5) + scale_x_reverse(breaks = seq(0,1, 0.1)) + lims(y = c(min(d1$Lv3_W)-sd(d1$Lv3_W), max(d1$Lv3_W)+sd(d1$Lv3_W))) + labs(caption = "Numbers above points indicate the cut OOD; Red dashed line indicates the cut score using ESS-count") + theme_bw(base_size = input$font_size) + theme(plot.caption=element_text(size=18, hjust=0, face="italic", color="black")) })
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.