Skip to content

Commit

Permalink
Revised many parts of functions so that the minimal code work
Browse files Browse the repository at this point in the history
  • Loading branch information
@yhoriuchi
yhoriuchi committed Aug 17, 2023
1 parent e348303 commit 9ae9ca4
Show file tree
Hide file tree
Showing 11 changed files with 88 additions and 247 deletions.
68 changes: 5 additions & 63 deletions R/organize_data.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,26 +15,6 @@
#' @param .remove_ties TRUE if you want to remove ties for the attribute of interest (in profile-level analysis)
#' @keywords internal


# .dataframe <- df@data
# .remove_ties <- TRUE # must be logical
#
# # Profile-level, MM
# # Example: Probability of choosing Level 3 of Attribute 1 (when the other profile is one of the other levels of the same attribute)
# .structure <- "profile_level"
# .att_choose <- "att1" # must be length==1
# .lev_choose <- "level3" # must be length==1
# .att_notchoose <- NULL # must be null
# .lev_notchoose <- NULL # must be null
#
# # Choice-level, MM
# # Example: Probability of choosing Level 3 of Attribute 1 when the other profile is Level 3 of Attribute 1.
# .structure <- "choice_level"
# .att_choose <- "att1" # must be length==1
# .lev_choose <- "level3" # must be length>=1
# .att_notchoose <- "att2" # must be length==1
# .lev_notchoose <- c("level1", "level2") # must be length>=1

organize_data <- function(
.dataframe,
.structure,
Expand Down Expand Up @@ -116,17 +96,19 @@ organize_data <- function(
# specify the attributes and levels of interest
attlev_choose <- stringr::str_c(.att_choose, ":", .lev_choose)

att_choose <- rlang::sym(.att_choose)

# keep relevant rows only
out2 <- out1 <- .dataframe %>%
dplyr::mutate(qoi_choose = !!rlang::sym(.att_choose)) %>%
dplyr::mutate(qoi_choose = !!att_choose) %>%
dplyr::filter(qoi_choose %in% c(attlev_choose)) %>%
dplyr::select(-matches("att\\d+$"))

if (.remove_ties == TRUE){

out2 <- out1 %>%
dplyr::group_by(id, task) %>%
dplyr::mutate(ties = n() - 1) %>%
dplyr::mutate(ties = dplyr::n() - 1) %>%
dplyr::ungroup() %>%
dplyr::filter(ties == 0) %>%
dplyr::select(-ties)
Expand Down Expand Up @@ -178,47 +160,7 @@ organize_data <- function(

out <- out3
}

# organize the data frame -------------------------------------------------

# keep relevant rows only
# out2 <- .dataframe %>%
# dplyr::rename(att = !!rlang::sym(.attribute)) %>%
# dplyr::filter(att %in% c(att_levels))
#
# if (structure == "profile_level"){
#
# if (.remove_ties == TRUE){
#
# out2 <- out2 %>%
# dplyr::group_by(id, task) %>%
# dplyr::mutate(ties = n() - 1) %>%
# dplyr::ungroup() %>%
# dplyr::filter(ties == 0) %>%
# dplyr::select(-ties)
#
# }
#
# } else if (structure == "choice_level"){
#
# out2 <- out2 %>%
#
# # pivot the data frame
# tidyr::pivot_wider(id_cols = c(id, task, agree),
# names_from = profile,
# values_from = c(att, selected)) %>%
#
# # keep relevant rows only
# dplyr::filter(att_1 == att_levels[1] & att_2 == att_levels[2]) %>%
#
# # make "selected"
# dplyr::mutate(selected = selected_2) %>%
#
# # add a column to record the levels of interest
# dplyr::mutate(att = str_c(att_levels, collapse = ", "))
#
# }


# Keep necessary variables only and return --------------------------------

# data frame to estimate IRR
Expand Down
69 changes: 24 additions & 45 deletions R/pj_estimate.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,33 +32,6 @@
#' @param .se_type_2 the standard error type to estimate MM or AMCE (see \code{\link[estimatr]{lm_robust}}): \code{"classical"} (default)
#' @return A data frame of estimates

# .data <- df
# .structure = "choice_level"
# .estimand = "mm"
#
# .att_choose = "att1"
# .lev_choose = "level2"
# .att_notchoose = "att2"
# .lev_notchoose = "level1"
#
# .att_choose_b = "att1"
# .lev_choose_b = "level3"
# .att_notchoose_b = "att1"
# .lev_notchoose_b ="level1"
#
# .se_method = "analytical"
# .irr = NULL
# .remove_ties = TRUE
# .ignore_position = FALSE
# .n_sims = NULL
# .n_boot = NULL
# .weights_1 = NULL
# .clusters_1 = NULL
# .se_type_1 = "classical"
# .weights_2 = NULL
# .clusters_2 = NULL
# .se_type_2 = "classical"

pj_estimate <- function(
.data,
.structure = "profile_level",
Expand Down Expand Up @@ -91,10 +64,10 @@ pj_estimate <- function(
estimand <- rlang::arg_match0(.estimand, c("mm", "amce"))
se_method <- rlang::arg_match0(.se_method, c("analytical", "simulation", "bootstrap"))

if (is.null(.att_choose)){
if (structure == "choice_level" & is.null(.att_choose)){
stop("The .att_choose argument must be specified.")
}
if (is.null(.lev_choose)){
if (structure == "choice_level" & is.null(.lev_choose)){
stop("The .att_choose argument must be specified.")
}

Expand Down Expand Up @@ -284,16 +257,16 @@ pj_estimate <- function(

temp2 <- temp1$data_for_estimand %>%
dplyr::mutate(selected = ifelse(qoi_1 %in% attlev_choose, selected_1, selected_2),
qoi_choose = str_c(attlev_choose, collapse = ", "),
qoi_notchoose = str_c(attlev_notchoose, collapse = ", ")) %>%
qoi_choose = stringr::str_c(attlev_choose, collapse = ", "),
qoi_notchoose = stringr::str_c(attlev_notchoose, collapse = ", ")) %>%
dplyr::select(-matches("_\\d$"))

} else{

temp2 <- temp1$data_for_estimand %>%
dplyr::mutate(selected = ifelse(qoi_choose_1 %in% attlev_choose, selected_1, selected_2),
qoi_choose = str_c(attlev_choose, collapse = ", "),
qoi_notchoose = str_c(attlev_notchoose, collapse = ", ")) %>%
qoi_choose = stringr::str_c(attlev_choose, collapse = ", "),
qoi_notchoose = stringr::str_c(attlev_notchoose, collapse = ", ")) %>%
dplyr::select(-matches("_\\d$"))

}
Expand All @@ -305,8 +278,8 @@ pj_estimate <- function(
temp2 <- temp1$data_for_estimand %>%
dplyr::filter(qoi_1 == attlev_notchoose & qoi_2 == attlev_choose) %>%
dplyr::mutate(selected = selected_2, # If .ignore_position == FALSE, selected = 1 if the left profile is chosen
qoi_choose = str_c(attlev_choose, collapse = ", "),
qoi_notchoose = str_c(attlev_notchoose, collapse = ", ")) %>%
qoi_choose = stringr::str_c(attlev_choose, collapse = ", "),
qoi_notchoose = stringr::str_c(attlev_notchoose, collapse = ", ")) %>%
dplyr::select(-matches("_\\d$"))

} else{
Expand All @@ -315,8 +288,8 @@ pj_estimate <- function(
dplyr::filter(qoi_notchoose_1 == attlev_notchoose & qoi_choose_2 == attlev_choose) %>%

dplyr::mutate(selected = selected_2,
qoi_choose = str_c(attlev_choose, collapse = ", "),
qoi_notchoose = str_c(attlev_notchoose, collapse = ", ")) %>%
qoi_choose = stringr::str_c(attlev_choose, collapse = ", "),
qoi_notchoose = stringr::str_c(attlev_notchoose, collapse = ", ")) %>%
dplyr::select(-matches("_\\d$"))

}
Expand Down Expand Up @@ -529,7 +502,8 @@ pj_estimate <- function(
weights = .weights_1,
clusters = .clusters_1,
se_type = .se_type_1,
data = data_for_irr) %>% tidy()
data = data_for_irr) %>%
estimatr::tidy()

irr <- reg_irr$estimate[1]
var_irr <- reg_irr$std.error[1]^2
Expand Down Expand Up @@ -557,7 +531,8 @@ pj_estimate <- function(
weights = .weights_2,
clusters = .clusters_2,
se_type = .se_type_2,
data = data_for_estimand) %>% tidy()
data = data_for_estimand) %>%
estimatr::tidy()

# the critical t-value
critical_t <- abs((reg_mm$conf.low[1] - reg_mm$estimate[1]) / reg_mm$std.error[1])
Expand All @@ -573,7 +548,8 @@ pj_estimate <- function(
weights = .weights_2,
clusters = .clusters_2,
se_type = .se_type_2,
data = data_for_estimand) %>% tidy()
data = data_for_estimand) %>%
estimatr::tidy()

# the critical t-value
critical_t <- abs((reg_amce$conf.low[2] - reg_amce$estimate[2]) / reg_amce$std.error[2])
Expand Down Expand Up @@ -716,13 +692,15 @@ pj_estimate <- function(
weights = .weights_1,
clusters = .clusters_1,
se_type = .se_type_1,
data = bs_sample_1) %>% tidy()
data = bs_sample_1) %>%
estimatr::tidy()

reg_mm <- estimatr::lm_robust(selected ~ 1,
weights = .weights_2,
clusters = .clusters_2,
se_type = .se_type_2,
data = bs_sample_2) %>% tidy()
data = bs_sample_2) %>%
estimatr::tidy()

# calculate the means
mm_uncorrected <- reg_mm$estimate[1]
Expand Down Expand Up @@ -850,14 +828,15 @@ pj_estimate <- function(
weights = .weights_1,
clusters = .clusters_1,
se_type = .se_type_1,
data = bs_sample_1) %>% tidy()
data = bs_sample_1) %>%
estimatr::tidy()

reg_amce <- estimatr::lm_robust(selected ~ x,
weights = .weights_2,
clusters = .clusters_2,
se_type = .se_type_2,
bs_sample_2) %>% tidy()

bs_sample_2) %>%
estimatr::tidy()

# calculate the means
amce_uncorrected <- reg_amce$estimate[2]
Expand Down
24 changes: 5 additions & 19 deletions R/predict_tau.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,15 +25,11 @@
#' head(exampleData1)
#'
#' outcomes <- paste0("choice", seq(from = 1, to = 8, by = 1))
#' outcomes <- c(outcomes, "choice1_repeated_flipped")
#'
#' outcomes1 <- c(outcomes, "choice1_repeated_flipped")
#' reshaped_data <- reshape_projoint(
#' .dataframe = exampleData1,
#' .idvar = "ResponseId",
#' .outcomes = outcomes,
#' .outcomes_ids = c("A", "B"),
#' .alphabet = "K",
#' .repeated = TRUE,
#' .flipped = TRUE)
#' .outcomes = outcomes1)
#'
#' tau1 <- predict_tau(reshaped_data)
#' tau1
Expand All @@ -42,15 +38,10 @@
#' data("exampleData2")
#' head(exampleData2)
#'
#' outcomes <- paste0("choice", seq(from = 1, to = 8, by = 1))
#' outcomes <- c(outcomes, "choice1_repeated_notflipped")
#' outcomes2 <- c(outcomes, "choice1_repeated_notflipped")
#' reshaped_data <- reshape_projoint(
#' .dataframe = exampleData2,
#' .idvar = "ResponseId",
#' .outcomes = outcomes,
#' .outcomes_ids = c("A", "B"),
#' .alphabet = "K",
#' .repeated = TRUE,
#' .outcomes = outcomes2,
#' .flipped = FALSE)
#'
#' tau2 <- predict_tau(reshaped_data)
Expand All @@ -60,14 +51,9 @@
#' data("exampleData3")
#' head(exampleData3)
#'
#' outcomes <- paste0("choice", seq(from = 1, to = 8, by = 1))
#' outcomes <- c(outcomes)
#' reshaped_data <- reshape_projoint(
#' .dataframe = exampleData3,
#' .idvar = "ResponseId",
#' .outcomes = outcomes,
#' .outcomes_ids = c("A", "B"),
#' .alphabet = "K",
#' .repeated = FALSE)
#'
#' tau3 <- predict_tau(reshaped_data)
Expand Down
21 changes: 1 addition & 20 deletions R/projoint.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,12 +40,7 @@
#'
#' reshaped_data <- reshape_projoint(
#' .dataframe = exampleData1,
#' .idvar = "ResponseId",
#' .outcomes = outcomes,
#' .outcomes_ids = c("A", "B"),
#' .alphabet = "K",
#' .repeated = TRUE,
#' .flipped = TRUE)
#' .outcomes = outcomes)
#'
#' projoint(reshaped_data)

Expand Down Expand Up @@ -79,7 +74,6 @@ projoint <- function(
warning("Both .qoi and .estimand are specified; using the value from .qoi.")
}


if(.structure == "choice_level" & is.null(.ignore_position)){
.ignore_position = TRUE
}
Expand Down Expand Up @@ -127,41 +121,28 @@ projoint <- function(

}


#' @param x A \code{\link{projoint_results}} object
#' @param ... Optional arguments; currently none accepted
#' @export
#' @rdname projoint

print.projoint_results <- function(x, ...) {
# ## What should we put here?
cat("[A projoint output]\n",
"Estimand:", x@estimand, "\n",
"Structure:", x@structure, "\n",
"IRR:", x@irr, "\n",
"Tau:", x@tau, "\n",
"Remove ties:", x@remove_ties, "\n",
"SE methods:", x@se_method)
# Tau and whether it's estimated or assumed
# Some details about the data set
# No results
}


#' @param object A \code{\link{projoint_results}} object
#' @param ... Optional arguments; currently none accepted
#' @export
#' @rdname projoint

summary.projoint_results <- function(object, ...) {
## What should we put here?
# ests <- object@estimates
# labs <- object@labels
# left_join(ests,
# labs,
# by = c("att_level_choose" = "level_id"))
object@estimates

}


Expand Down
2 changes: 1 addition & 1 deletion R/projoint_diff.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -133,7 +133,7 @@ projoint_diff <- function(
# return estimates --------------------------------------------------------

if (is.null(.irr)){
irr <- str_c("Assumed (", .irr, ")")
irr <- stringr::str_c("Assumed (", .irr, ")")
} else{
irr <- "Estimated"
}
Expand Down
Loading

0 comments on commit 9ae9ca4

Please sign in to comment.