@@ -318,44 +318,54 @@ print_bar <- function(){
318318# ' @rdname pxweb_explorer
319319# ' @keywords internal
320320pxe_print_choices <- function (x ){
321+ checkmate :: assert_class(x , " pxweb_explorer" )
321322 obj <- pxe_pxobj_at_position(x )
322323 show_no <- x $ print_no_of_choices
323324
324325 if (pxe_position_is_metadata(x )){
325326 mddims <- pxweb_metadata_dim(pxe_pxobj_at_position(x ))
326327 md_pos <- pxe_metadata_path(x , as_vector = TRUE )
327- no_choices <- unname(mddims [md_pos [length(md_pos )]])
328+ no_rows_to_print <- unname(mddims [md_pos [length(md_pos )]])
329+ choices_idx <- 1 : no_rows_to_print
328330 } else {
329- no_choices <- length(obj )
331+ choices_df <- pxweb_levels_choices_df(obj )
332+ no_rows_to_print <- nrow(choices_df )
333+ choices_idx <- choices_df $ choice_idx
330334 }
331335
332- if (x $ print_all_choices | no_choices < = show_no * 2 ){
333- print_idx <- 1 : no_choices
336+ if (x $ print_all_choices | no_rows_to_print < = show_no * 2 ){
337+ print_idx <- 1 : no_rows_to_print
334338 } else {
335- print_idx <- c(1 : show_no , NA , (no_choices - show_no + 1 ): no_choices )
339+ print_idx <- c(1 : show_no , NA , (no_rows_to_print - show_no + 1 ): no_rows_to_print )
336340 }
337341
338342 print_idx_char <- as.character(print_idx )
339- print_idx_char_nmax <- max(nchar(print_idx_char ), na.rm = TRUE )
340- print_idx_char <- str_pad(print_idx_char , print_idx_char_nmax )
343+ choice_idx_char <- as.character(choices_idx )
344+ choice_idx_char_nmax <- max(nchar(choice_idx_char ), na.rm = TRUE )
345+ choice_idx_char <- str_pad(choice_idx_char , choice_idx_char_nmax )
341346
342347 for (i in seq_along(print_idx )){
343348 if (is.na(print_idx [i ])) {
344349 cat(" \n " )
345350 next
346351 }
352+
347353 if (pxe_position_is_metadata(x )){
348354 if (x $ show_id ){
349355 cat(" [" , print_idx_char [i ], " ] : " , obj $ variables [[length(md_pos )]]$ valueTexts [print_idx [i ]], " (" , obj $ variables [[length(md_pos )]]$ values [print_idx [i ]] ," )" , " \n " , sep = " " )
350356 } else {
351357 cat(" [" , print_idx_char [i ], " ] : " , obj $ variables [[length(md_pos )]]$ valueTexts [print_idx [i ]], " \n " , sep = " " )
352358 }
353359 } else {
354- if (x $ show_id ) {
355- cat( " [ " , print_idx_char [ i ], " ] : " , obj [[ print_idx [ i ]]] $ text , " ( " , obj [[ print_idx [ i ]]] $ id , " ) " , " \n " , sep = " " )
360+ if (obj [[ print_idx [ i ]]] $ type == " h " ) {
361+ txt <- paste( " \n " , paste(rep( " " , nchar( print_idx_char [ i ]) + 2 + 6 ), collapse = " " ), collapse = " " )
356362 } else {
357- cat (" [" , print_idx_char [ i ], " ] : " , obj [[ print_idx [i ]]] $ text , " \n " , sep = " " )
363+ txt <- paste0 (" [" , choice_idx_char [ print_idx [i ]], " ] : " )
358364 }
365+ txt <- paste0(txt , obj [[print_idx [i ]]]$ text )
366+ if (x $ show_id ) txt <- paste0(txt , " (" , obj [[print_idx [i ]]]$ id ," )" )
367+ txt <- paste0(txt , " \n " )
368+ cat(txt )
359369 }
360370 }
361371}
@@ -416,7 +426,9 @@ pxe_handle_input.numeric <- function(user_input, pxe){
416426 } else if (pxe_position_is_api_catalogue(pxe )) {
417427 pxe <- pxweb_explorer(obj [[user_input ]]$ id )
418428 } else {
419- new_pos <- obj [[user_input ]]$ id
429+ cdf <- pxweb_levels_choices_df(obj )
430+ choice_input <- which(cdf $ choice_idx == user_input )
431+ new_pos <- obj [[choice_input ]]$ id
420432 pxe <- pxe_add_position(pxe , new_pos )
421433 }
422434 assert_pxweb_explorer(pxe )
@@ -657,7 +669,7 @@ pxe_allowed_input.pxweb_explorer <- function(x){
657669 }
658670 }
659671
660- if (! x $ print_all_choices & pxe_position_choice_size (x ) > x $ print_no_of_choices * 2 ){
672+ if (! x $ print_all_choices & pxe_position_print_size (x ) > x $ print_no_of_choices * 2 ){
661673 input_df $ allowed [input_df $ code == " a" ] <- TRUE
662674 }
663675
@@ -811,13 +823,26 @@ pxe_position_is_api_catalogue <- function(x) {
811823# ' @param x a \code{pxweb_explorer} object to check.
812824# ' @keywords internal
813825pxe_position_choice_size <- function (x ) {
826+ if (pxe_position_is_metadata(x )){
827+ cs <- pxe_position_print_size(x )
828+ } else {
829+ obj <- pxe_pxobj_at_position(x )
830+ choices_df <- pxweb_levels_choices_df(obj )
831+ cs <- max(choices_df $ choice_idx , na.rm = TRUE )
832+ }
833+ cs
834+ }
835+
836+ # ' @rdname pxe_position_choice_size
837+ # ' @keywords internal
838+ pxe_position_print_size <- function (x ) {
814839 if (pxe_position_is_metadata(x )){
815840 md <- pxe_pxobj_at_position(x )
816841 md <- pxweb_metadata_dim(md )
817842 mdpos <- length(pxe_metadata_path(x , as_vector = TRUE ))
818843 cs <- unname(md [mdpos ])
819844 } else {
820- cs <- length(pxe_pxobj_at_position(x ))
845+ cs <- length(pxe_pxobj_at_position(x ))
821846 }
822847 cs
823848}
0 commit comments